zOs/war.rexx
/* rexx ****************************************************************
synopsis: WAR c <warFile> <ds>+
WAR x <warFile> ( <frPr> <toPr> )*
creates a warFile from a list of datasets and or members of a PDS
or extracts datasets and or members from a warFile,
arguments:
cf create warfile (lowercase)
xf extract members/datasets from warfile (lowercase)
<warfile> DSN of the warfile
<home> the prefix of added or extracted datasets, default userid
<ds> if <ds> is a PDS all members are added,
if a seqential dataset or a member of a PDS it is added
<frPr> <toPr> if no prefix pair is given, all dsn are extracted
to the same name
otherwise the prefix (of a DSN in warfile) is changed
from <frPr> to <toPr>, if no <frPr> matches
the file is not extracted
***********************************************************************/
parse arg args
call errReset 'hi'
m.charSetAdd = 0
m.transOld = '¨¦¢!' /* ¨ bar ¦ brokenBar ¢! square */
m.transNew = '!![]'
m.lib2dir = 0
if pos('?', args) > 0 then
return help()
else if args = '' then do
if 0 then
return errHelp('no args')
call warExtract 'rexx0.war', 'A540769.WK. tst/'
return
oPr = '~tst.war.'f('%t Y')
call warExtract 'rexx0.war', 'A540769.WK tst/' ,
, 'A540769.WK. ~TST.WAREXT.'
call warExtract '~TST.WAR.QK31O1MX(REXX4)' ,
, 'A540769.WK. ~TST.WAREXT.'
call warExtract '~TST.WAR.QK31O1MX(REXX5)' ,
, 'A540769.WK. ~TST.WAREXT.'
return
call warCreate oPr'(rexx0)', '~wk.rexx'
return
call warCreate oPr'(sql0)', '~wk.sql'
call warCreate oPr'(jcl0)', '~wk.jcl'
call warCreate oPr'(plb0)', '~wk.plb'
call warCreate oPr'(skels0)', '~wk.skels'
call warCreate oPr'(wk0)', '~wk.wk'
return
end
parse upper var args fun war list
if fun == 'C' then
call warCreate war, list
else if fun == 'X' then
call warExtract war, list
else if fun == 'CWK' then do
call warCreate war'(rexx0)', '~wk.rexx'
call warCreate war'(sql0)', '~wk.sql'
call warCreate war'(jcl0)', '~wk.jcl'
call warCreate war'(plb0)', '~wk.plb'
call warCreate war'(skels0)', '~wk.skels'
call warCreate war'(wk0)', '~wk.wk'
end
else if fun == 'XWK' then do
m.lib2dir = 1
td = './'
ft = 'A540769.WK.' td 'A540769.TMP.CASE' td'TX' 'DSN.TX.CASE' td'TX'
do fx=1 to xFileList(ff, 'war')
say fx m.ff.fx
call warExtract m.ff.fx, ft
end
return
end
else
call errHelp 'war fun='fun 'not supported in args' args
exit
warCreate: procedure expose m.
parse arg m.warDsn, list
m.warCntF = 0
m.warCntL = 0
m.warCntB = 0
m.warDsX = 0
if m.charsetAdd then do
m.charSet = ''
call readDsn '~wk.rexx(charSet)', cc.
do cx=1 to cc.0
call checkCharset(cc.cx)
end
end
charSetL = length(m.charSet)
call warDsnOC 2
do lx=1 to words(list)
i = dsn2jcl(word(list, lx))
if pos('(', i) > 0 then
call warCreAddLib i
else if pos("<"sysDsn("'"i"(noMbr)'")">" ,
, "<OK> <MEMBER NOT FOUND>") > 0 then
call warCreAddLib i"(*)"
else
call warCreAddSeq i
end
call warDsnOC 1
call warSayAdded
if m.charSetAdd & (length(m.charSet) <> charSetL) then do
cy = cc.0
do cZ = charSetL+1 by 20 to length(m.charSet)
cy = cy + 1
cc.cy = 'plus ' substr(m.charset, cZ, 20)
end
call writeDsn '~wk.rexx(charset)', cc., cy, 1
say 'charset' cc.cy
end
return
endProcedure warCreate
warCreAddLib: procedure expose m.
parse arg iDsn
/* open lmId for ispf member statistics */
lmid = lmOpen(iDsn)
if verify(dsnGetMbr(iDsn), '*?', 'm') <= 0 then do
call warCreAddMbr iDsn, lmId
end
else do mx=1 to mbrList(ml, iDsn)
call warCreAddMbr dsnSetMbr(iDsn, m.ml.mx), lmId
end
call lmClose lmid
return
endProcedure warCreAddLib
warCreAddMbr: procedure expose m.
parse arg iDsn, lmId
call adrIsp 'lmmFind dataid('lmid') member('dsnGetMbr(iDsn)')' ,
'stats(yes) noLla'
h2 = 'cre='translate(ZLC4DATE, '-', '/') ,
'mod='translate(ZLM4DATE'-'zlmTime':'zlmSec, '-.', '/:') zlUser
call warCreAddFile iDsn, h2
return
endProcedure warCreAddMbr
warCreAddFile: procedure expose m.
parse arg m.iDsn, hd
if m.warFiB > 5e06 then
call warDsnOC 3
call dsnAlloc 'dd(iDD)' m.iDsn
h.1 = '}[---' strip(m.iDsn hd) '---'
if length(h.1) < 80 then
h.1 = left(h.1, 80, '-')
if m.charsetAdd then
call checkCharset h.1
call warWriteDD h., 1
lc = 1
bc = length(h.1)
do while readDD(iDD, i., 1000)
lc = lc + i.0
do ix=1 to i.0
li = i.ix
if abbrev(li, '}[') then
li = '}[\'substr(li, 3)
li = strip(li, 't')
if m.charsetAdd then
call checkCharSet(li)
if li == '' then
i.ix = ' '
else
i.ix = li
bc = bc + length(i.ix)
end
call warWriteDD i.
end
call tsoClose iDD
call tsoFree iDD
m.warCntF = m.warCntF + 1
m.warCntL = m.warCntL + lc
m.warFiB = m.warFiB + bc
if m.warCntF // 50 = 0 then
call warSayAdded
return
endProcedure warCreAddFile
warCreAddFile22: procedure expose m.
parse arg m.iDsn, hd
call dsnAlloc 'dd(iDD)' m.iDsn
h.1 = left('}[---' strip(m.iDsn hd)' ', max(80, length(hd)+16),'-')
call warWriteDD h., 1
lc = 1
bc = length(h.1)
pat = 'SELECT GRANT DELETE INSERT DROP ALTER REPLACE TRUNCATE' ,
'UPDATE CREATE RENAME DESCRIBE FROM INTO TABLE DATABASE' ,
'INDEX VIEW UNION PHP ADMIN CATALOG CATEGORY SAVE STATS RX',
'CSS 1=1 TILE MAIL KEY OP SETTING OPEN PAGE EXTRA SETTI SQL' ,
'REQUEST URI'
tF = ' 'm.ut_rxid
tx = 35
tT = substr(tF, tx+1)left(tF, tx)
do while readDD(iDD, i., 1000)
lc = lc + i.0
do ix=1 to i.0
li = i.ix
if abbrev(li, '}[') then
li = '}[\'substr(li, 3)
li = strip(li, 't')
li = translate(li, tT, tF)
/* lu = translate(li)
do px=1 to words(pat)
do forever
py = pos(word(pat, px), lu)
if py < 1 then
leave
li = insert('+', li, py+0)
lu = insert('+', lu, py+0)
end
end
*/ if li == '' then
i.ix = ' '
else
i.ix = li
bc = bc + length(i.ix)
end
call warWriteDD i.
end
call tsoClose iDD
call tsoFree iDD
m.warCntF = m.warCntF + 1
m.warCntL = m.warCntL + lc
m.warFiB = m.warFiB + bc
if m.warCntF // 10 = 0 then
call warSayAdded
return
endProcedure warCreAddFile22
warSayAdded: procedure expose m.
if m.charSetAdd then
cm = ' charset' length(m.charset)','
else
cm = ''
say m.warCntF 'files' m.warCntL 'lines,' ,
(m.warCntB+ m.warFiB) 'bytes,'cm ,
m.iDsn 'added to' m.tso_dsn.warDD
return
warDsnOC: procedure expose m.
parse arg oc
if oc // 2 == 1 then do
m.warCntB = m.warCntB + m.warFiB
call tsoClose warDD
call tsoFree warDD
end
if oc >= 2 then do
m.warFiB = 0
m.warDsX = m.warDsX + 1
if m.warDsX > length(m.ut_numUc) then
call err 'overflow' m.warDsX
m.warDsn = overlay(substr(m.ut_numUc, m.warDsX, 1),
, m.warDsn, length(m.warDsn) - 1)
call dsnAlloc m.warDsn 'dd(warDD) ::v100'
call tsoOpen warDD, 'w'
end
return
endProcedure warDsnOC
warWriteDD:
call writeDD warDD, arg(1), arg(2)
return
endSubroutine warWriteDD
warExtract: procedure expose m.
parse arg m.warDsn, frTo
call xOpen warDD, m.warDsn, 'r'
to.1 = ''
do fx=1
fr.fx = word(frTo, 2*fx-1)
if fr.fx = '' then
leave
to.fx = dsn2jcl(word(frTo, 2*fx))
if to.fx = '' then
call err 'incomplete pair' fx':' frTo
end
fr.0 = max(1, fx-1)
cL = 0
cF = 0
toDD = ''
m.warExt.lmDsn = ''
do while xReadSt(warDD, i.)
do ix=1 to i.0
if symbol('m.transOld') == 'VAR' then
i.ix = translate(i.ix, m.transNew, m.transOld)
if \ abbrev(i.ix, '}[') then
iterate
if abbrev(i.ix, '}[\') then do
i.ix = '}['substr(i.ix, 4)
iterate
end
if toDD <> '' then
toDD = warExtWriClo(toDD, toFx, ix-1,toN,cre,mod,usr)
parse var i.ix sepB dsn cre mod usr sepE
if (sepB == '}[---' & abbrev(cre, 'cre=') ,
& abbrev(mod, 'mod=') & abbrev(sepE, '---')) then
nop
else if (sepB == '}[---' & cre == 'cre=' ,
& (abbrev(usr, '---') | abbrev(sepE, '---'))) then
cre = ''
else
call err 'bad header' i.ix '#' || (cL+ix) 'in' m.warDsn
cF = cF + 1
do fx=1
if fx > fr.0 then do
call err 'ignore' cF '#' || (cL + ix) dsn cre mod usr
leave
end
if abbrev(dsn, fr.fx) then do
toN = to.fx || substr(dsn, length(fr.fx)+1)
if m.lib2dir & right(toN, 1) == ')' then
toN = overlay('/', left(toN, length(toN)-1),
, lastPos('(', toN))
say 'extract' cF '#' || (cL + ix) dsn cre mod usr,
'=>' toN
toDD = xOpen('TODD', toN '::f', 'w')
m.warExt.oCnt = 0
toFx = ix+1
leave
end
end
end
if toDD <> '' then
call warExtWri toDD, toFx, i.0
toFx = 1
cL = cL + i.0
end
if toDD <> '' then
toDD = warExtWriClo(toDD, toFx, i.0 ,toN,cre,mod,usr)
call xSetStatsClose
say cF 'file,' cL 'lines in' m.warDsn
call xClose warDD
return
endProcedure warExtract
warExtWri: procedure expose m. i.
parse arg toDD, fx, tx
call xWriteSt toDD, i., fx, tx
m.warExt.oCnt = m.warExt.oCnt + tx + 1 - fx
return
endProcedure warExtWri
warExtWriClo: procedure expose m. i.
parse arg toDD, fx, tx, dsn, cre, mod, usr
call warExtWri toDD, fx, tx
call xClose toDD
call xSetStats m.toDD.file, cre, mod, usr
return ''
endProcedure warExtWriClo
checkCharSet: procedure expose m.
parse arg li
do forever
cx = verify(li, m.charset)
if cx = 0 then
return
m.charSet = m.charSet || substr(li, cx, 1)
end
endProcedure checkCharSet
/* copx ReginaRexx begin *********************************************/
xOpen: procedure expose m.
parse arg m, m.m.file creD , m.m.opt
if m.m.opt == 'r' then
res = stream(m.m.file, 'c', 'open read')
else if m.m.opt == 'w' then
res = stream(m.m.file, 'c', 'open write replace')
else
call err 'xOpen('m',' m.m.file',' m.m.opt') bad opt' m.m.opt
if res \== 'READY:' then do
if m.m.opt == 'w' & creD <> '' & res == 'ERROR:2' then do
address system 'mkdir -pv' left(m.m.file, lastPos('/', m.m.file))
return xOpen(m, m.m.file, m.m.opt)
end
call err 'xOpen('m',' m.m.file',' m.m.opt') stream open failed:' res
end
m.m.open = 1
return m
endProcedure xOpen
xClose: procedure expose m.
parse arg m
res = stream(m.m.file, 'c', 'close')
if res \== 'UNKNOWN' then
call err 'xClose('m') stream close failed:' res
m.m.open = 1
return m
endProcedure xClose
xFileList: procedure expose m.
parse arg m, aDi
fs = stream(aDi, 'c', 'fStat')
if word(fs, 8) \== 'Directory' then
call err aDi 'not a Direcotry, fStat:' fs
a = stream(aDi, 'c', 'query exists')
address system 'ls -1p' aDi with output replace stem q.
dx = 0
fx = 0
do qx=1 to q.0
f = copies(a'/', \ abbrev(q.qx, '/'))q.qx
if right(q.qx, 1) \== '/' then do
fx = fx+1
m.m.fx = f
end
else do
dx = dx+1
m.m.dir.dx = f
end
end
m.m.0 = fx
m.m.dir.0 = dx
return fx
endProcedure xFileList
xSetStats: procedure expose m.
parse arg file, cre, mod, usr
if length(mod) > 10 then
mTst = substr(mod, 5, 10) translate(substr(mod, 16), ':', '.')
else
mTst = '1970-01-01 01:01:01' /* unix epoch starts 1970, however, because of leap seconds, 00:00:00 is before the start! */
c = 'touch -md "'mTst'" "'file'"'
address system c
if rc \== 0 then
call err "xSetStats" c "rc="rc "mod='"mod"' mTst='"mTst"'"
return
endProcedure xSetStats
xSetStatsClose:
return
/* copx ReginaRexx end ***********************************************/
/* copx tsoRexx begin ************************************************/
xIspfSetStats: procedure expose m.
parse arg dsn, cre, mod, usr
if m.warExt.lmDsn <> dsnSetMbr(dsn) then do
m.warExt.lmDsn = dsnSetMbr(dsn)
m.warExt.lmId = lmOpen(m.warExt.lmDsn)
end
/* adrIsp 'lmmStats dataid('lmid') member(wsh) createD4(1908/04/01)',
'modDate4(2122/05/31) modTime(23:24:25) user(MyUser7)' */
st = 'curSize('m.warExt.oCnt') user('usr')' ,
'created4('translate(substr(cre, 5, 10), '/', '-')')' ,
'modDate4('translate(substr(mod, 5, 10), '/', '-')')' ,
'modTime('translate(substr(mod, 16, 8), ':', '.')')'
call adrIsp 'lmmStats dataid('m.warExt.lmid')' ,
'member('dsnGetMbr(dsn)')' st
return ''
endProcedure xIspfSetStats
xIspfSetStatsClose: procedure expose m.
if m.warExt.lmDsn <> '' then
call lmClose m.warExt.lmId
return
lmOpen: procedure expose m.
parse arg dsn
call adrIsp "lmInit dataid(lmid) dataset('"dsnSetMbr(dsn)"')"
call adrIsp 'lmOpen dataid('lmid')'
return lmid
endProcedure lmOpen
lmClose: procedure expose m.
parse arg lmid
call adrIsp 'lmClose dataid('lmid')'
call adrIsp 'lmFree dataid('lmid')'
return
endProcedure lmClose
/* copx tsoRexx end **************************************************/
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"["pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF']' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale ---------------------
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '[' plus
parse var aMid aLen '.' aPrec
if pos(']', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF']'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse arg dsn ., addPrefix /*????? linux no upper */
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
xReadSt:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
do ggLx=1 to ggCnt while lines(m.ggDD.file) > 0
call value ggSt || ggLx, lineIn(m.ggDD.file)
end
call value ggSt'0', ggLx - 1
return ggLx > 1
endProcedure xReadSt
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
xWriteSt:
parse arg ggDD, ggSt, ggFx, ggTx, ggRetDD
if ggFx == '' then
ggFx = 1
if ggTx == '' then
ggTx = value(ggst'0')
do ggIx=ggFx to ggTx
res = lineOut(m.ggDD.file, value(ggSt || ggIx))
if res \== '0' then
call err 'xWriteSt('ggDD',' ggSt '...) lineOut res='res', ix' ggIx '=' value(ggSt || ggIx)
end
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' & m.err_os \== 'UNIX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: ------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_uc25 = left(m.ut_uc, 25)
m.ut_alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/