zOs/REXX/BINDDB
/* REXX ----------------------------------------------------------------
bindDB: bind Interface for DB2
synopsis: bindDB B appl? install? rz (pgm conTok?)+
bindDB D appl? install? pgm+
bindDB E dBind dRes? dErr?
bindDB S dRes cmRes
bindDB R appl? install? rz pgm+
bindDB any bindCMN statement
b -> pgm, d -> dbp, r -> rebind, e -> exe, s -> res
bindDB calls bindCMN and shows the output in a view session
the 3-letter statments are passed unchanged to bindCM
in short statements missing parameters are filled with defaults
parameters are described under bindCMN, except:
dBind: DSN with (generated) bind statements
dRes : DSN for Result
dErr : DSN for errReport
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
parse upper arg mFun mRest
m.mArg = space(arg(1), 1)
m.inlineCMN = 1 /* 1= call dbp in diesem rexx
0= call dbp in rexx bindCMN (zum Testen|) */
m.sql_dbSys = ''
call errReset 'hi', "call errReset 'hi'" ,
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end"
if mFun == '' then do
if 1 then
exit errHelp('no input')
parse upper value 'PGM abc4567890 f -t jobTest' ,
'alab 01.01.14 rzy yavmur 839695E39692F0F1' ,
'pgm2 839695E39692F0F2' with mFun mRest
parse upper value 'e A540769.WK.REXX(BINDteb3)' with mFun mRest
parse upper value 's A540769.WK.TEXV(bindRes3) 8' with mFun mRest
parse upper value 's WOK.U0000.P0.RZ4AKT.HK.RQ2DBR.RES.D151211',
with mFun mRest
end
if mFun == 'B' then
call callCmn 'PGM' argExp(1, mRest)
else if mFun == 'D' then
call callCmn 'DBP' argExp(0, mRest)
else if mFun == 'E' then do
/* call dsnAlloc 'dd(dbrmLib) CMN.DIV.P0.DB2J.#000223.DBR' */
call dsnAlloc 'dd(dbrmLib) A540769.WK.DBRM'
call callCmn 'EXE' mRest
call tsoFree dbrmLib
end
else if mFun == 'R' then
call callCmn 'REBIND' argExp(1, mRest)
else if mFun == 'S' then do
if words(mRest) == 1 then
mRest = mRest 0
call callCmn 'RES' mRest
end
else
call callCmn mFun mRest
exit 0
callCmn: procedure expose m.
parse arg fun rest
fr = ''
if wordPos(fun, 'DBP PGM REBIND') > 0 then do
showDD = 'BIND'
call dsnAlloc 'dd(bind) new ::f'
end
else if fun = 'EXE' then do
parse var rest in out err
if in = '' then
return errHelp('i}no input for Exe:' fun rest)
fr = fr word(dsnAlloc( 'dd(bind)' in), 2)
if out = '' then
call dsnAlloc 'dd(bindRes) new ::v2500'
else
call dsnAlloc 'dd(bindRes)' out '::v2500'
if err = '' then
call dsnAlloc 'dd(bindErr) new ::f'
else
call dsnAlloc 'dd(bindErr)' err '::f'
showDD = 'BINDRES BINDERR'
end
else if fun = 'RES' then do
if words(rest) <> 2 then
return errHelp('i}bad input for Res:' fun rest)
fr = fr word(dsnAlloc( 'dd(bindRes)' word(rest, 1)), 2)
rest = word(rest, 2)
showDD = ''
end
else
return errHelp('i}bad fun' fun 'in:' fun rest)
if m.inlineCMN then
res = cmnWork(fun, rest)
else
res = bindcmn(fun rest)
doShow = showDD \== '' & (abbrev(res, 'ok') | fun = 'EXE')
if \ (m.inlineCMN & doShow) then
say fun 'res =' res
call tsoFree fr
if doShow then do sx=1 to words(showDD)
dd1 = word(showDD, sx)
call adrIsp "LMINIT DATAID(lmmId) ddName("dd1") ENQ(SHRW)"
eRc = adrIsp("edit dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
end
if showDD \== '' then
call tsoFree showDD
if \ abbrev(res, 'ok') then
call err 'e}'res
else if doShow & ((eRc \== 0 & eRc \== 4) | lRc \== 0) then
call err 'e}'m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure callCmn
argExp: procedure expose m.
parse arg isLo, args
res = argEx2(isLo, args)
if \ m.inlineCMN then
if space(res, 1) <> space(args, 1) then
say 'expanding' args '==>' res
return res
endProcedure argExp
argEx2: procedure expose m.
parse arg isLo, w1 w2 rest
if appl = '' then
call err 'i}no arguments'
if isLo then
h = userid() 't' left('bindDB:'translate(m.mArg, '-',' '), 20) ,
mvsvar('symdef', 'jobname')' '
else
h = ''
i = anaInst(w1)
if i \== '' then
return h'appl' i w2 rest
i = anaInst(w2)
if i \== '' then
return h || w1 i rest
i = anaInst(date('s'))
if length(w1) == 4 then
return h || w1 i w2 rest
else
return h'appl' i w1 w2 rest
endProcedure argEx2
/* |||| copy bindCMN und adrISP ||||||||||||||||||||||||||||||||||||||*/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- 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 *************************************************/
/* REXX ----------------------------------------------------------------
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
m.sql_dbSys = ''
call errReset "hi", "call errReset 'hi'" ,
"; call errSay 'f}'ggTxt; call errCleanup",
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end" ,
"; exit 'error' ggTxt"
parse upper arg fun rest
/*%SYSDATE */
/*%SYSTIME */
say "BINDCMN Vers:" SYSDATE"/"SYSTIME "/Function:" FUN "/" REST
if wordPos(fun, 'DBP PGM EXE RES') < 1 then
return errHelp('i}bad fun' fun 'in:' fun rest)
exit cmnWork(fun, rest)
cmnWork: procedure expose m.
parse arg fun, rest
if pos('?', fun rest) > 0 | fun = '' then
exit help()
if fun <> 'EXE' then
call sqlConnect 'DP4G'
if fun == 'PGM' then
res = doPGM(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'REBIND' then
res = doRebind(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'DBP' then
res = doDBP(anaAI(rest))
else if fun == 'EXE' then
res = doExe()
else if fun == 'RES' then
res = doRes(rest)
else
return errHelp('i}bad args:' fun rest)
if m.sql_dbSys <> '' then
call sqlDisconnect
return res
endProcedure cmnWork
exit 0
anaAI: procedure expose m.
parse arg appl inst rest
if appl = '' then
call err 'i}no arguments'
if rest = '' then
call err 'i}no program:' appl inst rest
i = anaInst(inst)
if i == '' then
call err 'i}bad installDate' inst 'in:' appl inst rest
if length(appl) <> 4 then
call err 'i}bad appl' appl 'in:' appl inst rest
return appl i rest
endProcedure anaAI
ana7: procedure expose m.
parse arg args
parse arg cmPkg f1 com cmJob appl inst rz rest
if length(cmPkg) > 10 then
call err 'i}bad cmPkg' cmPkg 'args:' args
if length(f1) <> 1 then
call err 'i}bad cmFun' f1 'args:' args
if length(com) > 20 then
call err 'i}bad com' com 'args:' args
if length(cmJob) > 20 then
call err 'i}bad cmJob' cmJob 'args:' args
i = word(anaAI(appl inst 'x'), 2)
if length(rz) <> 3 | \ abbrev(rz, 'R') then
call err 'i}bad rz' rz 'args:' args
return cmPkg f1 com cmJob appl i rz rest
endProcedure ana6
anaInst: procedure expose m.
parse arg inst
today = translate('78.56.1234', date('s'), '12345678')
i0 = translate(inst, '000000000', '123456789')
if i0 == '00000000' then
return translate('78.56.1234', inst, '12345678')
else if i0 == '0000' then
return translate('34.12', inst, '1234')substr(today, 6)
else if i0 == '00.00' then
return inst || substr(today, 6)
else if i0 == '00.00.00' then
return left(inst,6)substr(today, 7, 2)right(inst, 2)
else if i0 == '00.00.0000' then
return inst
else
return ''
endProcedure anaInst
doPGM: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindRz" ,
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doPGM
doRebind: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040Rebind",
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doRebind
doDBP: procedure expose m.
parse arg appl inst pgms
call insPgm appl inst, pgms
res = selWri( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindDBP")
call sqlCommit
call sqlDisConnect
return res
endProcedure doDBP
doExe: procedure expose m.
call tsoOpen 'BIND', 'R'
call readDD 'BIND', i., '*'
call tsoClose 'BIND'
ox = 0
ex = 0
ey = ex
ccMax = 0
ccId = 0
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
str = 'b'
do ix = 1 to i.0 /* each line */
/* concat one command */
li = strip(doExeComm(i.ix), str)
if iCmd = '' then
ey = ex + 2
else
ey = ey + 1
e.ey = li
if right(li, 1) == '-' then do
iCmd = iCmd || left(li, length(li)-1)
str = 't'
iterate
end
else if right(li, 1) == '+' then do
iCmd = iCmd || left(li, length(li)-1)
str = 'b'
iterate
end
else do
iCmd = iCmd || li
end
/* we have one command in iCmd */
str = 'b' /* for next cmd */
if iCmd = '' then
iterate
if iFirst == '' then do /* dsn command */
iFirst = strip(iCmd)
iCmd = ''
iterate /* look next bind */
end
if translate(iCmd) = 'END' then do /* end of program */
ox = ox+1 /* result for program */
o.ox = 'res' ccId,
'job' strip(jobInfo(name))'#'strip(jobInfo(num)) ,
'id' m.doExe.iId 'pgm' m.doExe.iPgm
if ccId > 0 then
if length(eM) <= 2000 then
o.ox = o.ox 'err' eM
else
o.ox = o.ox 'err' left(eM, 1997)'...'
ccMax = max(ccMax, ccId)
ccId = 0 /* reset variables */
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
iterate
end
/* we got one bind in iCmd */
do while queued() > 0 to /* clear input queue */
parse pull pOld
say 'err pulled:' pOld
ccMax = max(99, ccMax)
end
say iFirst '=>' space(iCmd, 1) /* execute dsn bind end */
queue iCmd
queue 'end'
cc = adrTso(iFirst, '*')
do tx=1 to m.tso_trap.0 /* say output of bind */
say m.tso_trap.tx
end
cc2 = cc
if cc < 0 | \ datatype(cc, 'n') then
cc2 = 999
if cc2 > 0 then do
ez = ex+1 /* write whole command to err */
e.ez = iFirst
ex = ey
end
eM = doExeMsg(eM, cc2 ccId, iFirst, iCmd)
ccId = max(ccId, cc2)
say e.actMsg
iCmd = '' /* end one bind */
end /* each line */
if iCmd \== '' | iFirst \== '' then
call err 'fileEnd but iCmd='iCmd', iFirst='iFirst
if ccId \== 0 | eM \== '' then
call err 'fileEnd but ccId='ccId', eM='eM
if ex = 0 then do
ex = ex + 1
e.ex = 'ccMax =' ccMax
end
call tsoOpen 'BINDRES', 'W'
call writeDD 'BINDRES', 'o.', ox
call tsoClose 'bindRes'
call tsoOpen 'BINDErr', 'W'
call writeDD 'BINDErr', 'e.', ex
call tsoClose 'BINDErr'
if ccMax <= 4 then
return 'ok ccMax' ccMax 'for exe'
else
return 'err ccMax' ccMax 'for exe'
endProcedure doExe
doExeMsg: procedure expose m. e. ex
parse arg eM, cc2 ccId, iFirst, iCmd
m0 = sysvar(sysNode)
cx = pos('(', iFirst)
if cx > 0 & right(iFirst, 1) == ')' then
m0 = m0'/'substr(iFirst, cx+1, length(iFirst)-cx-1)
else
m0 = m0'/'iFirst
uCmd = translate(iCmd)
cx = pos('PACKAGE(', uCmd)
cy = pos('MEMBER(', uCmd)
if cx > 0 & cy > 0 then do
col = word(substr(iCmd, cx+8), 1)
if right(col, 1) == ')' then
col = left(col, length(col)-1)
mbr = word(substr(iCmd, cy+7), 1)
if right(mbr, 1) == ')' then
mbr = left(mbr, length(mbr)-1)
sCmd = left(iCmd, min(cx, cy)-1) col'.'mbr
end
else do
sCmd = iCmd
end
if length(m0) > 30 then
actM = left(m0, 27)'...' sCmd
else
actM = m0 sCmd
if cc2 > 4 | cc2 < 0 then
e.actMsg = strip(left('error cc='cc2 actM, 80))
else if cc2 > 0 then
e.actMsg = strip(left('warning cc='cc2 actM, 80))
else do
e.actMsg = strip(left('ok cc='cc2 actM, 80))
ex = ex + 1
e.ex = e.actMsg
return eM
end
actM = ''
do tx=1 to m.tso_trap.0
t1 = m.tso_trap.tx
ex = ex + 1
e.ex = left(t1, 80)
if wordPos(word(t1, 1), 'DSNX200I') > 0 then
iterate
j = space(t1, 1)
if j == 'USING CMNBATCH AUTHORITY' ,
| j == 'PLAN=(NOT APPLICABLE)' ,
| j == 'DBRM='m.doExe.iPgm then
iterate
cx = pos('=', j)
if cx > 1 then
if pos('='left(j, cx),
, '=SQLSTATE=CSECT NAME=RDS CODE=') > 0 then
iterate
actM = actM' 'j
end
if eM == '' then
return m0':' actM';'
else if cc2 > ccId then
return m0':' actM';' eM
else
return eM m0':' actM';'
endProcedure doExeMsg
doExeComm: procedure expose m.
parse arg src
res = ''
cy = -1
do forever
cx = pos('/*', src, cy+2)
if cx < 1 then
return res || substr(src, cy+2)
res = res || substr(src, cy+2, cx-cy-2)
cy = pos('*/', src, cx+2)
if cy < 1 then
com = strip(substr(src, cx+2))
else
com = strip(substr(src, cx+2, cy-cx-2))
say '/*' com
w1 = word(com, 1)
if w1 == 'beginRzPgm' then
m.doExe.iPgm = strip(subword(com, 2))
else if w1 == 'id' then
m.doExe.iId = strip(subword(com, 2))
if cy < 1 then
return res
end
endProcedure doExeComm
doRes: procedure expose m.
parse arg cmRes
if ^ (cmRes == 0 | cmRes == 8) then
call err 'cmRes bad cmRes =' cmRes
call readDD bindRes, i., '*'
call tsoClose bindRes
maxCC = 0
if i.0 < 1 then
return err('e}no lines in dd bindRes')
do ix=1 to i.0
parse var i.ix cRes res cJob jobPP cId id cFu pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
if length cFu <> 1 & pos('@', cFu) > 0 then do
cFu = ' '
parse var i.ix cRes res cJob jobPP cId id pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
end
parse var pkgTst pkg '@' tst
parse var rzDbSys rz '/' dbSys
parse var appIns appl '@' install
if cRes \== 'res' then
return err('e}res (not' cRes') expected in res' ix':'i.ix)
if cJob \== 'job' then
return err('e}job (not' cJob') expected in res' ix':'i.ix)
if cId \== 'id' then
return err('e}id (not' cId') expected in res' ix':'i.ix)
if cPgm \== 'pgm' then
return err('e}pgm (not' cPgm') expected in res' ix':'i.ix)
if pgm = '' then
return err('e}pgm missing in res' ix':'i.ix)
if length(cFu) <> 1 then
return err('e}bad cmFun' cFu ix':'i.ix)
if cEr \== '' & cEr \== 'err' then
return err('e}bad errFlag='cEr eMsg ix':'i.ix)
/* no error: we will see missing/spurios errormsg in table
if (cEr == '') <> (res == 0) then
return err('e}res='res 'but err='cEr eMsg ix':'i.ix)
if cEr \== '' & eMsg == '' then ??? till now empty for rc=4
return err('e}no error message in res' ix':'i.ix) */
if length(res) > 4 | res == '' then
call err 'i}bad res =' res 'in' arg(1) res
if res >= 0 & datatype(res, 'n') then
maxCC = max(res, maxCC)
else
maxCC = max(999, maxCC)
eMsg = translate(eMsg, ',', 'FF'x) /* token separator */
if length(eMsg) > 2000 then
eMsg = left(eMsg, 1997)'...'
asUni = "as varchar(6000) ccsid unicode"
call sqlUpdate 3, "update oa1p.tQZ043BindGen" ,
"set result = '"res"', cmJob = '"jobPP"'" ,
", resTst = current timestamp" ,
", cmRes =" cmRes ,
", errMsg = case when length(cast("quote(eMsg, "'") ,
asUni ")) <= 2000 then" quote(eMsg,"'") ,
"else" quote(left(eMsg, 1500)'...', "'") "end" ,
"where genId =" id ,
"and cmPkg = '"pkg"' and genTst = '"tst"'" ,
"and appl = '"appl"' and install = '"install"'" ,
"and rz = '"rz"' and dbSys = '"dbSys"'"
if m.sql.3.updateCount <> 1 then
return err(m.sql.3.updateCount "rows updated for res."ix ,
i.ix)
end
call sqlCommit
call sqlDisConnect
return 'ok,' i.0 'results maxCC' maxCC
endProcedure doRes
/*--- insert pgms into table bindPgm --------------------------------*/
insPgm: procedure expose m.
parse arg appl inst, pgms
do px = 1 to checkPgms(pgms)
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install)",
"values ('"appl"', '"m.pid.px"', '"inst"')"
end
return
endProcedure insPgm
/*--- insert pgms into table bindPgm and bindGen --------------------*/
insPgmGen: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
genSql = "select genTst, pgm, genid from final table(" ,
"insert into oa1p.tQZ043BindGen" ,
"(cmPkg, cmFun, com, cmJob, appl, install, rz, dbSys" ,
",pgm, conTok, genTst)" ,
"values('"cmPkg"', '"f1"', '"com"', '"cmJob"', '"appl"'",
", '"inst"', '"rz"', '?'"
do px = 1 to checkPgms(pgms)
if px=1 then
m.genTst = sql2One(genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"'" ,
", max(current timestamp, value((select max(genTst)" ,
"from oa1p.tqz043BindGen)+ 1e-6 seconds" ,
", current timestamp))))" , bindGen)
else
call sql2One genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"', '"m.genTst"'))",
, bindGen
if m.genTst \== m.bindGen.genTst then
call err 'genTst mismatch' m.genTst '<>' m.bindGen.genTst
m.pid.px.genid = m.bindGen.genId
m.pid.px.genTst = m.bindGen.genTst
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install, id, info)",
"values ('"appl"', '"m.pid.px"', '"inst"'," m.pid.px.genId ,
", 'id" m.pid.px.genId f1 cmPkg"@"m.pid.px.genTst"')"
end
return
endProcedure insPgmGen
checkPgms: procedure expose m.
parse upper arg pgms
px = 0
wx=1
wZ = words(pgms)
do while wx <= wZ
px = px+1
p1 = word(pgms, wx)
wx = wx + 1
if length(p1) < 4 | length(p1) > 8 then
call err 'i}bad program' p1 'in' pgms
if symbol('m.p2x.p1') == 'VAR' then
call err 'i}duplicate program' p1 'in' pgms
m.pid.px = p1
m.p2x.p1 = px
c1 = word(pgms, wx)
if length(c1) = 16 & verify(c1, '00123456789ABCDEF')=0 then do
m.pid.px.conTok = c1
wx = wx+1
end
else
m.pid.px.conTok = left('', 16, 0)
end
if px < 1 then
call err 'i}no programs'
m.pid.0 = px
return m.pid.0
endProcedure checkPgms
/*--- select and insert bind statements,
check programs, update dbSys in bindGen
write to dd bind ---------------------------------------------*/
selWriUpd: procedure expose m.
parse arg qry
call sql2St ,
"select dbSys, pgm, line from final table(" ,
"insert into oa1p.tQZ044BindLine (genId, seq, line)",
"include(dbSys char(4), pgm char(8))",
"select p.Id, b.seq, b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"left join oa1p.tQZ040BindPgm p" ,
"on b.pgm = p.pgm )",
"order by pgm, seq", bb, ":m.dst.dbSys, :m.dst.pgm, :m.dst"
return checkPgmUpdWri(bb, 1)
endProcedure selWriUpd
/*--- select bind statements, check programs,
write to dd bind ---------------------------------------------*/
selWri: procedure expose m.
parse arg qry
call sql2St ,
"select b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"order by pgm, seq", bb, ":m.dst, :m.dst.dbSys, :m.dst.pgm"
return checkPgmUpdWri(bb, 0)
endProcedure selWriUpd
/*--- check programs, if updDbSys then update dbSys in bindGen
write to dd bind ---------------- ----------------------------*/
checkPgmUpdWri: procedure expose m.
parse arg bb, updDbSys
ds = ''
do sx=1 to m.bb.0
p1 = strip(m.bb.sx.pgm)
if p1 = m.sqlNull | m.bb.sx.dbSys = m.sqlNull then
iterate
if symbol('m.p2x.p1') \== 'VAR' then
call err 'fetched pgm' p1 'not in list'
if symbol('p2d.p1') \== 'VAR' then do
px = m.p2x.p1
p2d.p1 = strip(m.bb.sx.dbSys)
if wordPos(p2d.p1, ds) < 1 then
ds = ds p2d.p1
if updDbSys then do
call sqlUpdate 7, "update oa1p.tQZ043BindGen" ,
"set dbSys = '"p2d.p1"'",
"where genId =" m.pid.px.genId ,
"and genTst = '"m.pid.px.genTst"'" ,
"and pgm = '"p1"'"
if m.sql.7.updateCount <> 1 then
call err 'set dbSys updateCount' ,
m.sql.7.updateCount '<> 1'
end
end
else if p2d.p1 \== strip(m.bb.sx.dbSys) then do
if updDbSys then
call err 'pgm p1 multi dbSys' p2d.p1 m.bb.sx.dbSys
end
end
mis = ''
do px=1 to m.pid.0
p1 = m.pid.px
if symbol('p2d.p1') \== 'VAR' then
mis = mis p1
end
if mis \== '' then
call err 'w}nothing generated for programs' mis
call tsoOpen 'BIND', 'W'
call writeDD 'BIND', 'M.bb.'
call tsoClose 'BIND', 'W'
return 'ok' m.pid.0 'programs' m.bb.0 'lines'
endProcedure checkPgmUpdWri
/* rexx */
jobInfo: procedure expose m.
parse arg w
v = 'JOBINFO_'w
if symbol('m.v') == 'VAR' then
return m.v
if m.jobInfo_Ini == 1 then
call err 'no jobInfo for' w
m.jobInfo_Ini = 1
call #jInfo_jobInfo
call mPut 'JOBINFO_TYPE', #JINFO_JTYPE
call mPut 'JOBINFO_NUM' , #JINFO_JNUM
call mPut 'JOBINFO_NAME', #JINFO_JNAME
return jobInfo(w)
endProcedure jobInfo
/*
** >>Jobinfo
*/
#JINFO_JOBINFO:
#JINFO@cvt = storage(10,4) /* FLCCVT-PSA data area */
#JINFO@cvtsname = storage(d2x(c2d(#JINFO@cvt) + 340),8) /* CVTSNAME */
#JINFO@tcbp = storage(d2x(c2d(#JINFO@cvt)),4) /* CVTTCBP */
#JINFO@tcb = storage(d2x(c2d(#JINFO@tcbp)+4),4)
#JINFO@tiot = STORAGE(D2X(C2D(#JINFO@tcb)+12),4) /* Get TIOT address */
#JINFO@jscb = STORAGE(D2X(C2D(#JINFO@tcb)+180),4)
#JINFO@ssib = STORAGE(D2X(C2D(#JINFO@jscb)+316),4)
#JINFO@jinfo = STORAGE(D2X(C2D(#JINFO@tiot)),24)
#JINFO_JTYPE = STORAGE(D2X(C2D(#JINFO@ssib)+12),3)
#JINFO_JNUM = strip(storage(D2X(C2D(#JINFO@ssib)+15),5),l,0)
#JINFO_JNAME = substr(#JINFO@jinfo,1,8)
#JINFO_JPROC = substr(#JINFO@jinfo,9,8)
#JINFO_JPROCSTEP = substr(#JINFO@jinfo,17,8)
#JINFO_CVTSNAME = #JINFO@cvtsname /* system name */
drop #JINFO@cvt #JINFO@tcbp #JINFO@tcb #JINFO@tiot #JINFO@jscb
drop #JINFO@ssib #JINFO@jinfo #JINFO@cvtsname
return
#JINFO_DROP:
DROP #JINFO_JTYPE #JINFO_JNUM #JINFO_JNAME #JINFO_JPROC #JINFO_JPROCSTEP
return
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
m.sql.cx.fetchCode = cd
st = 'SQL.'cx'.COL'
call sqlRemVars st
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
return
end
m.sql.cx.fetchVars = ''
vrs = ''
sNu = ''
if abbrev(src, '?') then do
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end
end
else if src <> '' then do kx=1 to words(src)
cn = word(src, kx)
call sqlRexxAddVar cn, 0, m.sql.cx.d.kx.sqlType // 2
end
else do kx=1 to m.sql.cx.d.sqlD
call sqlRexxAddVar m.sql.cx.d.kx.sqlName, 1 ,
, m.sql.cx.d.kx.sqlType // 2
end
m.sql.cx.fetchVars = substr(vrs, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
sqlCol2kx: procedure expose m.
parse arg cx, nm
if symbol('M.SQL.CX.COL.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col.nm
if m.sql.cx.col.kx \== nm then
call err 'sqlCol2kx' nm '==>' kx 'but' m.sql.cx.col.kx
return kx
endProcedure sqlCol2kx
sqlRemVars: procedure expose m.
parse arg st
if symbol('m.st.0') == 'VAR' then do
do sx=1 to m.st.0
nm = m.st.sx
drop m.st.nm m.st.sx
end
end
m.st.0 = 0
return
endProcedure sqlRemVars
sqlAddVar: procedure expose m.
parse arg st, sNa, nicify
sx = m.st.0 + 1
if 1 | nicify then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('m.st.sNa') == 'VAR' then
sNa = 'COL'sx
end
m.st.0 = sx
m.st.sx = sNa
m.st.sNa = sx
return sNa
endProcedure sqlAddVar
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 1 then do
hahi = m.sql_HaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql_HaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL 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
if ggRet == '*' then
return m.tso_rc
else if wordPos(m.tso_rc, ggRet) > 0 then
return m.tso_rc
else
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper 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 expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
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 expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
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: 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
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- 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
/*--- 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 readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- 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
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 readDDNxEnd
/*--- 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 upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
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, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd 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, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
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)
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_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
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 saySt(splitNl(err, '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_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.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
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
call saySt(splitNl(err, 'rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if 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 = 32756
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 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
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(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- 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
/*--- 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
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csmNull begin **************************************************
pseudo csm Modul, to avoid missing modules error from rexx compiler
***********************************************************************/
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
call err 'csmAlloc not copied into this rexx'
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
call err 'csmLikeAtts not copied into this rexx'
/* copy csmNull end ***************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
call adrTso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'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.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- 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
/*--- 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 = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' 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 saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
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
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- 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 out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* 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_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
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
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- 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 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
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_alfLc, m.ut_alfUc)
/*--- 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
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
/* copy ut end ********************************************************/