zOs/REXX.O08/CATCOPSQ
/* rexx */
parse arg fun
say timing() fun 'begin'
call errReset 'h'
call mIni
call oFldIni
call sqlIni
call sqlConnect DBOF
call sql2Cursor 1, 'SELECT C.DBNAME, C.TSNAME, C.DSNUM, C.TIMESTAMP,' ,
'C.ICTYPE, C.DSNAME,' ,
'CHAR(C.COPYPAGESF * 1024 * S.PGSIZE) COPIED' ,
'FROM SYSIBM.SYSCOPY C, SYSIBM.SYSTABLESPACE S' ,
"WHERE C.ICTYPE IN ('F', 'I')" ,
'AND S.DBNAME = C.DBNAME' ,
'AND S.NAME = C.TSNAME' ,
/* "and c.dbName = 'DA540769'" ,
*/ 'ORDER BY 1, 2, 3, 4 DESC' ,
'WITH UR'
call sqlOpen 1
say timing() 'opened' fun
x = 0
if fun = 'type' then do
do while sqlFetch(1, a)
x = x + 1
if x // 10000 = 1 then
say timing() x fun m.a.dbName m.a.tsName m.a.dsNum
end
say timing() x fun m.a.dbName m.a.tsName m.a.dsNum
end
else if fun = 'vars' then do
do while sqlExec('fetch c1 into :vd,:vTs,:vNu,:vTi,:vTy,:vDs,:vCo' ,
,0 100) <> 100
x = x + 1
if x // 10000 = 1 then
say timing() x fun vd vTs vNu
end
say timing() x fun vd vTs vNu
end
else if fun = 'varsOP' then do
st = 'execSql fetch c1 into :vd,:vTs,:vNu,:vTi,:vTy,:vDs,:vCo'
do forever
address dsnRexx st
if rc <> 0 then do
if sqlCode = 100 then
leave
ggSqlStmt = st
call err sqlmsg()
end
x = x + 1
if x // 10000 = 1 then
say timing() x fun vd vTs vNu
end
say timing() x fun vd vTs vNu
end
else if fun = 'feDesc' then do
do while sqlExec('fetch c1 into descriptor :m.sql.1.d',
,0 100) <> 100
x = x + 1
if x // 10000 = 1 then
say timing() x fun,
m.sql.1.d.1.sqlData m.sql.1.d.2.sqlData m.sql.1.d.3.sqlData
end
say timing() x fun,
m.sql.1.d.1.sqlData m.sql.1.d.2.sqlData m.sql.1.d.3.sqlData
end
else if fun = 'for' then do
do while sqlExec('fetch c1 for 10 rows' ,
'into :vd,:vTs,:vNu,:vTi,:vTy,:vDs,:vCo' ,
,0 100) <> 100
x = x + 1
if x // 10000 = 1 then
say timing() x fun,
m.sql.1.d.1.sqlData m.sql.1.d.2.sqlData m.sql.1.d.3.sqlData
end
say timing() x fun,
m.sql.1.d.1.sqlData m.sql.1.d.2.sqlData m.sql.1.d.3.sqlData
end
else
call err 'bad fun' fun
call sqlClose 1
call sqlDisconnect
say timing() fun 'disconnected'
exit
ddal = dsnAlloc('~wk.texv(syscopy)')
dd = word(ddAl, 1)
call readDDBegin dd
x = 0
z = 0
cDb = 0
cTs = 0
cPa = 0
old = ''
curr = '2008-03-13-11.11'
last = '2008-03-12-11.11'
keys = 'B N C L O TOT'
do kx=1 to words(keys)
ky = word(keys, kx)
c.ky.f.By = 0
c.ky.f.cn = 0
c.ky.i.By = 0
c.ky.i.cn = 0
end
do while readDD(dd, i., 1000)
x = x + i.0
do y=1 to i.0
z = z + 1
if z // 10000 = 0 then
say 'en' x 'z' z 'db' cDb 'ts' cTs 'pa' cPa ,
db'.'ts'.'pa'|'
if old ^== left(i.y, 20) then do
if sta == 'C' then
say 'still changing' db ts pa
if left(old, 8) ^== left(i.y, 8) then do
cDb = cDb+1
db = strip(left(i.y, 8))
end
if left(old, 16) ^== left(i.y, 16) then do
cTs = cTs+1
ts = strip(substr(i.y, 9, 8))
end
cPa = cPa + 1
pa = c2d(substr(i.y, 17, 4))
old = left(i.y, 20)
sta = 'B'
end
parse var i.y 21 tst 47 tp 48 dsn . 92 bytes .
if sta == 'B' then
if tst <<= curr then
sta = 'N'
if sta == 'C' then do
/* say 'changing' dsn
*/ end
if tp = 'F' then do
if tst << last then
if sta == 'C' then
sta = 'L'
else
sta = 'O'
end
/* say sta tp dsn
*/ c.sta.tp.cn = c.sta.tp.cn + 1
c.sta.tp.by = c.sta.tp.by + bytes
if sta == 'N' then
if tp = 'F' then
sta = 'C'
if sta == 'L' then
sta = 'O'
end
call sf 'nach ' curr, b
call sf 'neu' , n
call sf 'archivieren' , c
call sf 'letzte Arch. vor' last, l
call sf 'alt' , o
call sf 'total' , tot
end
call readDDEnd dd
interpret subWord(ddAl, 2)
say timing() 'en' x 'z' z 'db' cDb 'ts' cTs 'pa' cPa
exit
sf:
parse arg tit, ky
if c.title ^== 1 then do
say left('', 40) left('full.copies', 9+1+8, '.') ,
left('incremental.copies', 9+1+8, '.')
say left('', 40) right('Anzahl', 9) right('Bytes', 8) ,
right('Anzahl', 9) right('Bytes', 8)
c.title = 1
end
say left(tit, 40) right(c.ky.f.cn, 9) format(c.ky.f.by, 1, 2, 2, 0),
right(c.ky.i.cn, 9) format(c.ky.i.by, 1, 2, 2, 0)
if ky <> 'TOT' then do
c.tot.f.cn = c.tot.f.cn + c.ky.f.cn
c.tot.f.by = c.tot.f.by + c.ky.f.by
c.tot.i.cn = c.tot.i.cn + c.ky.i.cn
c.tot.i.by = c.tot.i.by + c.ky.i.by
end
return
/* copy sql begin ***************************************************
sql interface
sqlIni --> nur sql ohne o und j Anbindung
sqlOini --> sql mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sql.ini = 1
call mIni
m.sql.null = '---'
return
endProcedure sqlIni
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
sqlPrepare: procedure expose m.
parse arg cx, src, desc
call sqlExec 'prepare s'cx 'from :src'
if desc == 1 | (desc == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
sqlExecute: procedure expose m.
parse arg cx
do ix=1 to arg()-1
val = arg(ix+1)
if val ^== m.sql.null then do
m.sql.cx.i.ix.sqlInd = 0
m.sql.cx.i.ix.sqlData = val
end
else do
m.sql.cx.i.ix.sqlInd = -1
end
end
if ^ m.noInsert then /* ??? wk test */
call sqlExec 'execute s'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure
sqlExeImm: procedure expose m.
parse arg src
call sqlExec 'execute immediate :src'
return
endProcedure exeImm
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlExec 'prepare s'cx 'into :M.SQL.'cx'.D from :src'
call sqlExec 'declare c'cx 'cursor for s'cx
if ty == '*' | ty = '' then do
flds = 'SQL.'cx'.FLD'
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
flds = oFlds(ty)
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
ff = m.Sql.cx.FMT
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
sqlOpen: procedure expose m.
parse arg cx
return sqlExec('open c'cx)
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
sqlFetchInto:
parse arg ggCx, ggVars
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sql.null, m.fo.ix)
end
return 1
endProcedure sqlFetch
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st)
return 1
endProcedure sqlFetchLn
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
sqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
call sqlExec "connect" ggSys, ggRetCon ,1
return
endProcedure sqlConnect
sqlDisconnect: procedure
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = 'sqlCode' sqlCodeText(sqlCode, sqlErrMc),
'\nstate' sqlState 'warn'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith\n '
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()[]', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
sqlCodeText: procedure expose m.
parse arg co, mc
expEq = 0
if symbol('m.sql.code.0') <> 'VAR' then do
dsn = "'A540769.wk.texv(sql)'"
dsn = "'ORG.U0009.B0106.KIUT23.TEXV(SQLCODES)'"
m.sql.code.0 = 0
if sysDsn(dsn) <> 'OK' then
say 'sqlCode dsn' dsn':' sysDsn(dsn)
else
call readDsn dsn, 'M.SQL.CODE.'
end
co = co + 0
if length(co) < 3 then
co = left(co, 3, 0)
if co > 0 then
co = '+'co
co = co' '
do cx=1 to m.sql.code.0 until abbrev(m.sql.code.cx, co)
end
if cx > m.sql.code.0 then
li = "<<text for sqlCode" co "not found>>"
else
li = m.sql.code.cx
cx = 1
px = 1
res = ''
do forever
nx = pos('${', li, cx)
if nx < 1 then
leave
ex = pos('}', li, nx)
if ex < cx then
call err 'closing } missing in' li
res = res || substr(li, cx, nx - cx)
if expEq then
res = res || '<<' || substr(li, nx+2, ex-nx-2) || ' = '
cx = ex+1
if px > length(mc) then do
res = res || '<<missing>>'
end
else do
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res || substr(mc, px, qx-px)
if expEq then
res = res'>>'
px = qx + 1
end
end
res = res || substr(li, cx)
do while px <= length(mc)
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res '<<extraMsgArg =' substr(mc, px, qx-px)'>>'
px = qx + 1
end
return res
endProcedure sqlCodeText
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure sqlDsn
/*--- sql o interface ------------------------------------------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.jOut, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "r£", m
return
endProcedure sqlLn
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType"),
, "jOpen call sqlOpen substr(m, 8)",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/* copy sql end **************************************************/
/* copy fmt begin **************************************************/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f = 'l' then
return left(v, l)
else if f = 'r' then
return right(v, l)
else if f = 's' then
if l = '' then
return strip(v, 't')
else
return strip(v, l)
else if f = 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, f
return fmt(v, f)
endProcedure fmtS $
/* copy fmt end **************************************************/
/* copy oFld begin ****************************************************/
oFldNew: procedure expose m.
parse arg name, va, st, flds, dup
if pos('*', name) > 0 then
name = oPut('O.CLA', name, , '*')
else
call oPut 'O.CLA', name, , 'n'
m.o.cla.name.inst = 0
m.o.cla.name.val = va
m.o.cla.name.stem = st
m.o.cla.name.FLD.0 = 0
m.o.cla.name.MET.0 = 0
return oFldAdd(name, flds, dup)
endProcedure oFldNew
oFldOnly: procedure expose m.
parse arg fs, dup
kk = space(fs, 1) dup
if symbol('m.o.fldOnly.kk') = 'VAR' then
return m.o.fldOnly.kk
nn = oFldNew('FldType*')
st = 'O.CLA.'nn'.FLD'
ll = ''
do wx=1 to words(fs)
ll = ll oPut(st, word(fs, wx), '=', dup)
end
if symbol('m.o.fldOnly.ll') = 'VAR' then
nn = m.o.fldOnly.ll
m.o.fldOnly.kk = nn
m.o.fldOnly.ll = nn
return nn
endProcedure oFldOnly
oFldCat: procedure expose m.
parse arg ty, st, fmt
flds = oFlds(ty)
res = ''
do ix=1 to m.flds.0
f = m.flds.ix
if fmt == '' then
res = res m.st.f
else
res = res fmt(m.st.f, m.fmt.ix)
end
return substr(res, 2)
endProcedure oFldCat
oFldAdd: procedure expose m.
parse arg cla, fs, dup
st = 'O.CLA.'cla'.FLD'
do ix=1 by 2 to words(fs)
call oPut st, word(fs, ix), word(fs, ix+1), dup
end
return cla
endProcedure oFldAdd
oFlds: procedure expose m.
parse arg type
return 'O.CLA.'type'.FLD'
oPut: procedure expose m.
parse arg st, k, v, dup
if dup = '*' then do
cx = pos('*', k)
if cx < 1 then
call err 'no * in key' k
k = oPutDupResolve(st, left(k, cx-1), 1)
end
else if symbol('m.st.k') = 'VAR' then do
if dup = '' | dup = 'o' then do
m.st.k = v
return k
end
if dup = '=' then do
if v <> m.st.k | ^ (v = '' & datatype(m.st.k, 'n')) then
call err 'not =: m.'st'.'k '=>' m.st.k '<>' v
return k
end
if dup = 'e' then
k = oPutDupResolve(st, k, 2)
else
call err 'key' k 'exists in' st 'but dup' dup
end
else if dup = 'o' then
call err 'old key' k 'does not exist in' st
if datatype(k, 'n') | words(k) <> 1 | pos('.', k) > 0 then
call err 'illegal name' name
x = m.st.0 + 1
m.st.0 = x
m.st.x = k
if v == '' then
m.st.k = x
else
m.st.k = v
return k
endProcedure oPut
oPutDupResolve: procedure expose m.
parse arg st, k, b
do ix=b
a = k || ix
if symbol('m.st.a') <> 'VAR' then
return a
end
endProcedure oPutDupResolve
/*--- parameterized types --------------------------------------------*/
oGetTypePara: procedure expose m.
parse arg m
if symbol('m.o.tyPa.m') == 'VAR' then
return m.o.tyPa.m
else
return '='
endProcedure oGetTypePara
oSetTypePara: procedure expose m.
parse arg m, type, noCall
if type = '' then
type = '='
if oGetTypePara(m) == type then
return
if noCall ^== 'noCall' then
interpret oObjMethod(m, 'oSetTypePara')
m.o.tyPa.m = type
return
endProcedure oSetTypePara
oFldIni: procedure expose m.
if m.oFld.ini = 1 then
return
m.oFld.ini = 1
m.o.cla.0 = 0
call oFldNew 'Class', '=', , ,
'INST = MET .<>= FLD .<>=Class STEM =Class'
return
endProcedure oFldIni
/* copy oFld end ***************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd <> '' & ds = '' & rest = '' then
return dd
if dd = '' then do
nn = m.adrTso
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return current time and cpu usage ------------------------------*/
timing:
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/