zOs/REXX/DB2UT
/* rexx ****************************************************************
db2Ut: Entwickler Interface für Db2 Utilites
dieses übernimmt verschiedene Funktionen von Db2Ut, typischerweise
in dieser Reihenfolge
* ohne parm: Aufruf von DB2Ut mit ispf newappl(DBUT)
* parm = panel: Anzeige des Panels und ausführen der Funktionen
* param = DB .... storedProcedure Db2UtilP aufrufen mit den
mitgegebenen Parametern
* rexxName = Db2UtilP Funktion der StoredProcedure Db2UtilP
************************************************************************
23.12.2008 W.Keller utTemplate mit m.explicitTempl
19.12.2008 F.Schuck REORG eingebaut
************************/ /* end help **********************************
09.12.2008 F.Schuck richtige Table fuer Load bzw. Fehlermeldung
04.12.2008 W.Keller fix uninitialisierte .delims variable
10.11.2008 W.Keller native jcl
17.10.2008 W.Keller delimited, help
17.09.2008 W.Keller neu
***********************************************************************/
m.self.version = '1.0 - 19.12.2008'
parse arg pArgs
parse upper var pArgs pA1 pA2 .
parse source s1 s2 s3 s4 s5
m.self.name = s3
m.out = 0
m.out.0 = 0
m.punch.0 = 0
m.debug = 0
m.maxRc = 0
call dbg 'db2Ut start' m.self.version 'args' pArgs
call dbg 'db2Ut start source' s1',' s2',' s3',' s4',' s5
call dbg 'db2Ut user' userid()
call catIni
call scanWinIni
m.id = userid()'.DB2UT'
m.cnf.procDb2Ut = 'DB2UTIL.DB2UTIL'
m.cnf.procSys = 'DB2ADMIN.DSNUTILS'
m.cnf.lf = '\'
m.cnf.eSt = '\' /* end of statement NO semicolon, lf */
m.mapTab = ''
m.templ.0 = 0
m.templ.copyD = "DSN('&SSID..&DB..&SN..P&PART..&UNIQ.')"m.cnf.lf,
"DATACLAS(ENN0X) MGMTCLAS(SUB#ADB1) STORCLAS(FAR$N)"m.cnf.lf,
"SPACE (100,10000) TRK"
m.templ.SYUTD = "DSN('&SSID..&DB..&SN..P&PART..&UNIQ..UT')"m.cnf.lf,
"DATACLAS(ENN0X) MGMTCLAS(COM#E001)"m.cnf.lf,
"SPACE (100,10000) TRK"
m.templ.SOUTD = "DSN('&SSID..&DB..&SN..P&PART..&UNIQ..SRT')"m.cnf.lf,
"DATACLAS(ENN0X) MGMTCLAS(COM#E001)"m.cnf.lf,
"SPACE (100,10000) TRK"
m.templ.srecd = ,
"DSN('&SSID..&DB..&SN..P&PART..D&YE(3).&MO.&DA..REC')"m.cnf.lf,
"DATACLAS(ENN0X) MGMTCLAS(COM#A032)"m.cnf.lf,
"SPACE (100,10000) TRK"
m.templ.new = ,
"DATACLAS(ENN0X) MGMTCLAS(COM#A041) STORCLAS(FAR$N)"m.cnf.lf,
"SPACE TRK MAXPRIME 600"
if s3 == 'DB2UTILP' then
call storedProcCall pArgs
else if pArgs = '' then
call switchIspfAppl
else if pA1 = 'PANEL' then
call doPanel
else if pA1 = 'DB' then
call sqlCallDb2Ut pA2, subWord(pArgs, 3)
else
call err 'bad pArgs' pArgs
mr = m.maxRc
call globalCleanup
exit mr
/*--- kleine Tests ---------------------------------------------------*/
exit testStoredProc('DBAF')
exit testmaptab()
exit testRebind()
call sqlCallDb2Ut
call testCopy1
exit
/*--- aufräumen am Ende des Programms --------------------------------*/
globalCleanup: procedure expose m.
if symbol('m.db') == 'VAR' & m.db <> '-' then do
call dbg 'committing in' m.db
call sqlCommit
call dbg 'disconnect from' m.db
call sqlDisconnect
end
do px=1 to m.punch.0
pu = m.punch.px
drop m.punch.pu
end
m.out.0 = 0
m.punch.0 = 0
m.maxRc = 0
drop m.db
return
endProcedure globalCleanup
/*--- set global variables -------------------------------------------*/
setGlobal: procedure expose m.
parse arg name, val
call dbg 'setting global' name '=' val
if name = 'DB' then do
if symbol('m.DB') == 'VAR' then
call err 'global db already set'
call sqlConnect val
end
m.name = val
return
endProcedure setGlobal
/***********************************************************************
panel Funktionen
***********************************************************************/
/*--- switch ispf application ----------------------------------------*/
switchIspfAppl: procedure expose m.
call adrIsp 'control errors return'
/* if we are in an edit macro, we must do a macro first */
call adrEdit 'macro (aa)', '*'
call adrIsp "select cmd(DB2UT panel) newappl(DBUT) passlib"
return
endProcedure switchIspfAppl
/*--- panel Verarbeitung ---------------------------------------------*/
doPanel: procedure expose m.
msg = ''
/* restart Punkt nach Fehlern */
doPanelRestart:
call adrIsp 'control errors return'
call errReset , 'signal doPanelErrHandler'
do forever
msg = doPanelOne(msg, errMsg)
call globalCleanup
if msg = 'end' then
exit /* nicht return wegen FehlerHandler | */
call doPanelErrMsg msg
end
/* error handler: Fehler anzeigen und wieder von vorn */
doPanelErrHandler:
call errReset 'h'
if ^ doPanelErrMsg(ggTxt) then do /* falls keine panel msg, */
call errSay ggTxt /* anzeigen im Tso */
msg = 'msg(dbut213)'
end
call globalCleanup
signal doPanelRestart
endProcedure doPanel
/*--- panelInfos aus FehlerMeldung rausholen -------------------------*/
doPanelErrMsg: procedure expose m. msg errmsg
parse arg txt
sx = pos('££', txt)
if sx < 1 then do
msg = ''
errMsg = ''
return 0
end
qq = substr(txt, sx+2)
ex = pos('££', qq)
if ex > 0 sx then
qq = left(qq, ex-1)
parse var qq msg '£' cur '£' errMsg
if msg = '' | length(msg) > 8 then
call err 'bad msg "'msg'" in' txt
msg = 'msg('msg')'
if cur <> '' then
msg = msg 'cursor('cur')'
return 1
endProcedure doPanelErrMsg
/*--- panel anzeigen und auf User reagieren --------------------------*/
doPanelOne: procedure expose m.
parse arg msg, errMsg
di = adrIsp('display panel(db2Ut)' msg, '*')
if di <> 0 then do
if di <> 4 & di <> 8 then
call out 'adrDisp rc' di
return 'end'
end
call mAdd mCut(st, 0), 'db' susy, 'id' id, t1 strip(obj1)
if t2 <> '' & obj2 <> '' then
call mAdd st, t2 strip(obj2)
if t3 <> '' & obj3 <> '' then
call mAdd st, t3 strip(obj3)
/* parameter für jede Utility Fun zusammenstellen */
do fx=1 to 3
fa = value('fu'fx)
if fa = '' then
iterate
if fa = 'LOA' | fa = 'UNL' then do
shr = 'SHRLEVEL' shr
if punch = '' then
punch = '-'
else
punch = dsn2jcl(punch)
if fa = 'UNL' then do
call mAdd st, fa dsn2jcl(loadf), punch, shr
if unli <> '' then
call mAdd st, 'LIMIT' unLi
if d = 'Y' then
call mAdd st, ' delimited' analyseDelimiter(delim)
end
else do
if punch = '' then do
if d = 'Y' then
oDelim = analyseDelimiter(delim)
else
oDelim = ''
end
else do
pn = loadPunch(punch)
if loadf ^== '' then
nop
else if pn ^== '' & m.pn.inDsn ^== '' then
loadf = m.pn.inDsn
oDelim = m.pn.delims
end
if loadf = '' then
return '££DBUT211£loadf££'
call mAdd st, fa dsn2jcl(loadf) shr 'resume' p
if oDelim <> '' then
call mAdd st, ' ' oDelim
if pn ^== '' then do
if t1 <> 'TB' | obj2 <> '' | obj3 <> '' ,
| verify(obj1, '*?,' , 'm') > 0 then
return '££DBUT218£t1££'
call mAdd st, ' into' obj1 m.pn.flds
end
end
end
else do
call mAdd st, fa
end
end
/* Funktion im gewählten runMode ausführen */
src = mCat(st, ' ')
call dbg 'panel db' susy 'src' src
call genJobcards mCut(jcl,0), jobCard1, jobCard2, jobCard3, jobCard4
if r = 'F' then do
call sqlCallDb2Ut susy, subword(src ,3)
end
else if r = 'V' then do
call genJcl jcl, susy, st
call outputSysprint jcl, 0
end
else if r = 'S' then do
call genJcl jcl, susy, st
call writeDsn 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', 'M.JCL.', , 1
end
else if r = 'N' then do
call nativeJcl jcl, susy, subword(src ,3)
call outputSysprint jcl, 0
end
else do
return '££dbut212£r££'
end
return ''
endProcedure doPanelOne
/*--- delimiter syntax umformen:
wir erlauben nackte Zeichen, Strings oder hex Strings
und mehrere dürfen zusammengehängt sein
- Utility ist restriktiver -------------------------------------*/
analyseDelimiter: procedure expose m.
parse arg delim
de = ''
dc = 0
call scanReset ds
call scanSrc ds, delim
do while ^ scanAtEnd(scanSkip(ds))
hex = 0
if scanString(ds, ''' x'' X'' " x" X"') then do
d1 = m.ds.val
hex = pos(left(m.ds.tok, 1), 'xX') > 0
end
else do
call scanChar ds, 1
d1 = m.ds.tok
end
if ^ hex then do
do xx=1 by 1 to length(d1)
de = de quote(substr(d1, xx, 1), "'")
dc = dc + 1
end
end
else do
d1 = translate(m.ds.val)
if verify(d1, '0123456789ABCDEF') > 0 ,
| length(d1) // 2 <> 0 then
call scanErr ds, 'bad hex literal' ,
'££DBUT216£delim£'d1'££'
do xx=1 by 2 to length(d1)
de = de "X'"substr(d1, xx, 2)"'"
dc = dc + 1
end
end
end
if dc > 3 then
call err 'mehr als drei Delimiter' ,
'££DBUT217£delim£'de'££'
de = de subword("',' '""' '.'", dc+1)
if words(de) <> 3 then
call err 'delimiter not 3 words:' de
return de
endProcedure analyseDelimiter
/*--- punchfile einlesen und analysieren, falls nötig ----------------*/
loadPunch: procedure expose m.
parse arg pu
if pu = '-' then
return ''
if symbol('m.punch.pu') = 'VAR' then
nd = m.punch.pu
else do
nd = mAdd(punch, pu)
m.punch.pu = nd
call analysePunch nd, pu
end
return nd
endProcedure loadPunch
/*--- analyse a punchfile ----------------------------------------------
nd for punch info
puDsn: dsn of the punch file to analyse --------------------*/
analysePunch: procedure expose m.
parse arg nd, puDsn
if sysdsn("'"puDsn"'") <> 'OK' then
call err 'punch fehlt: ££DBut214£punch£' ,
|| puDsn':' sysdsn("'"puDsn"'")'££'
rdr = catMake('-r', puDsn)
sc = scanUtilSql(rdr)
call scanUtil sc
ld = 0
do while m.sc.utilType <> ''
if m.sc.utilType <> 'u' then do
call scanUtil sc
end
else if m.sc.val == 'TEMPLATE' then do
parse value analyseTemplate(sc) with nm templ.nm
end
else if m.sc.val == 'LOAD' then do
if ld then
call scanErr sc, 'more than one load'
ld = 1
call analyseLoad nd, sc
x = m.nd.inddn
if symbol('templ.x') = 'VAR' then
m.nd.inDsn = templ.x
else
m.nd.inDsn = ''
end
else do
call scanUtil sc
end
end
if ld < 1 then
call scanErr sc, 'no load'
call jClose rdr
return
endProcedure analysePunch
/*--- analyse a utility template statement
return <template name> <dsn> ----------------------------*/
analyseTemplate: procedure expose m.
parse arg sc
if scanUtil(sc) ^== 'n' then
call scanErr sc, 'template name expected'
res = m.sc.val
do while ^ (scanUtil(sc) = 'u' | m.sc.utilType = '')
if m.sc.utilType == 'n' & m.sc.utilBrackets = 0 then do
if m.sc.val = 'DSN' then
res = res scanUtilValue(sc, 1)
end
end
if words(res) > 2 then
call err 'to many dsns in template' res
return res
endProcedure analyseTemplate
/*--- analyse load put atts into stem nd -----------------------------*/
analyseLoad: procedure expose m.
parse arg nd, sc
if scanUtil(sc) ^== 'n' & m.sc.val ^== 'DATA' then
call scanErr sc, 'load data expected'
/* the load into syntax is too complex to analyse completely
we only catch the interesting (and disturbing) parts */
m.nd.inDdn = ''
m.nd.part = ''
m.nd.flds = ''
m.nd.tb = ''
m.nd.delims = ''
intos = 0
do while 'u' ^== scanUtil(sc) & m.sc.utilType ^== ''
if m.sc.utilType ^= 'n' | m.sc.utilBrackets ^= 0 then do
if m.sc.utilType = '(' then do
if m.sc.utilBrackets ^== 1 | intos ^== 1 then
call scanErr 'bad brackets for fields'
call scanBack sc, '('
m.nd.flds = '('scanUtilValue(sc, 0, m.cnf.lf)')'
end
iterate
end
opt = m.sc.val
if wordPos(opt, 'INDDN PART') > 0 then do
m.nd.opt = scanUtilValue(sc)
end
else if wordPos(opt, 'WHEN CCSID') > 0 then do
vv = scanUtilValue(sc) /* skip over brackets */
end
else if opt = 'INTO' then do
intos = intos+1
if intos > 1 then
call scanErr sc, 'more than one into not implemented'
if scanUtil(sc) ^== 'n' | m.sc.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if ^ scanSqlQuId(scanSkip(sc)) then
call scanErr sc, 'table name expected'
m.nd.tb = m.sc.val
m.nd.tbQu = m.sc.tok
end
else if opt = 'FORMAT' then do
if scanUtil(sc) ^== 'n' then
call scanErr sc, 'format type expected'
if m.sc.val = 'UNLOAD' then
iterate
else if m.sc.val ^== 'DELIMITED' then
call scanErr sc, 'format' m.sc.val 'not supported'
parse value "',' '""', '.'" with d.col d.cha d.dec
do while scanUtil(sc) == 'n' ,
& wordPos(m.sc.val, 'COLDEL CHARDEL DECPT') > 0
ky = left(m.sc.val, 3)
if ^ scanString(scanSkip(sc), "' x' X'") then
call scanErr sc, 'delimiter string expected'
d.ky = m.sc.tok
if ^abbrev(d.ky, "'") then
upper d.ky
end
m.nd.delims = 'DELIMITED' d.col d.cha d.dec
end
end
return
endProcedure analyseLoad
/*--- jcl generieren für Run mit db2ut -------------------------------*/
genJobcards: procedure expose m.
parse arg oo
do ax=2 to arg()
if arg(ax) <> '' then
call mAdd oo, arg(ax)
end
return
endProcedure genJobcards
genJcl: procedure expose m.
parse arg oo, susy, st
call mAdd jclTso(oo, 'db2Ut', 'S1', 1), "%DB2UT -"
do ix = 1 to m.st.0
line = strip(m.st.ix)
sx = 1
of = 4 - 2 * (wordPos(translate(word(line, 1)),
, 'ID DB COP RUN REB LOA UNL' ) > 0)
do forever
px = pos(m.cnf.lf, line, sx)
if px = 0 then do
call mAdd oo, left('', of)substr(line, sx) '-'
leave
end
call mAdd oo, left('', of)substr(line, sx, px-sx) '-'
of = 4
sx = px + 1
end
end
ox = m.oo.0
m.oo.ox = left(m.oo.ox, length(m.oo.ox)-1)
do ox=1 to m.oo.0
if length(m.oo.ox) >= 72 then
call err 'genJcl line overflow ('length(m.oo.ox)'):' m.oo.ox
end
return
endProcedure genJcl
/***********************************************************************
sql call auf db2UtilP und Ausgabe Output
***********************************************************************/
/*--- connect und sql call auf db2UtilP ------------------------------*/
sqlCallDb2Ut: procedure expose m.
parse arg db, src
if db <> '' then
call sqlConnect db
rst = 'NO'
retcode = -9876
e = ''
z = 0
call debugSqlCurrent 'before sql call'
call dbg "call" m.cnf.procDb2Ut "("src", ...)"
call sqlExec "call" m.cnf.procDb2Ut "(:src, :rst)", 0 +466
call dbg 'after call src='src
call debugSqlCurrent 'after sql call'
call outputSysprint , 1
return 0
endProcedure sqlCallDb2Ut
/*--- session sysprint oder stem ausgeben ----------------------------*/
outputSysprint: procedure expose m.
parse arg stem, summ
if m.out & m.out.0 > 0 & stem = '' then do
call sysPrintInsert out /* restlichen Output einfügen */
m.out.0 = 0
end
/* outputfile utilPrt allozieren */
if listDsi('utilPrt' file) <= 4 then
listDsi = 0
else
listDsi = sysReason
call dbg 'listDsi(utilPrt file)' listDsi sysMsgLvl2
if sysVar('sysISPF') = 'ACTIVE' then do
ty = 1
call adrTso 'alloc reuse dd(utilPrt)',
'recfm(v b) lrecl(136) block(32760) dsorg(PS)'
end
else if listDsi <> 2 then do
ty = 0 /* bereits alloziert */
end
else if SYSVAR('SYSENV') = 'FORE' then do
ty = 2
call adrTso 'alloc reuse dd(utilPrt) dsName(*)',
'recfm(v b) lrecl(136) block(32760) dsorg(PS)'
end
else if adrTso( 'alloc reuse sysout(*) dd(utilPrt)',
'recfm(v b) lrecl(136) block(32760) dsorg(PS)',
, '*') = 0 then do
ty = 3
end
else do
ty = -1
say '--- sysprint output'
end
if ty >= 0 then
call writeDDBegin utilPrt
if stem = '' then do /* daten aus session.sysprint */
Call sqlPreOpen 2, 'SELECT SEQNO, TEXT' ,
'FROM SESSION.SYSPRINT ORDER BY 1'
call dbg 'utility output sysprint'
stem = mCut(qq, 0)
do while sqlExec('fetch c2 into :seq, :txt', 0 100) = 0
call mAdd stem, strip(substr(txt, 2), 't')
end
call sqlClose 2
end
bb = mCut(bb, 0)
if summ == 1 then do
do ox=1 to m.stem.0
if abbrev(m.stem.ox, '+++') then do
call mAdd bb, m.stem.ox
r = word(m.stem.ox, words(m.stem.ox))
if datatype(r, 'n') then
m.maxRc = max(m.maxRc, r)
end
end
call mAdd bb, '+++' myTime() 'max rc' m.maxRc, ''
end
aa = mCut(aa, 0)
all = bb stem
ox = 0
do ax=1 to words(all)
st = word(all, ax)
do sx = 1 to m.st.0
txt = strip(m.st.sx, 't')
if ty < 0 then do
say txt
end
else do
do cx=1 by 132 while cx+132 <= length(txt)
ox = ox + 1
out.ox = substr(txt, cx, 132)
end
ox = ox + 1
out.ox = substr(txt, cx)
if ox > 100 then do
call writeDD utilPrt, out., ox
ox = 0
end
end
end
end
call writeDD utilPrt, out., ox
call writeDDEnd utilPrt
call dbg 'utilprt type' ty 'end output'
if ty = 1 then do /* view ouput */
call adrIsp "LMINIT DATAID(vwId) DDNAME(utilPrt) ENQ(SHRW)"
call dbg 'dataid' vwId
call adrIsp "VIEW DATAID("vwId")", 0 4
call adrIsp "LMFREE DATAID("vwId")"
end
if ty >= 1 then
call adrTso 'free dd(utilPrt)', '*'
return 0
endProcedure outputSysprint
myTime: procedure
return time() 'cpu' strip(sysvar('syscpu'))
/*--- say the contents of session.sysprint ---------------------------*/
showSysPrint: procedure expose m.
p = ':m.st.sx.'
call sqlPreAllCl 12, 'select seqNo, text',
'from session.sysPrint order by seqNo asc', st,
, p'sq,' p'tx'
say '-- sysprint has' m.st.0 'records'
do sx=1 to m.st.0
say right(m.st.sx.sq, 3) strip(m.st.sx.tx, 't')
end
return
endProcedure showSysprint
/*--- insert the lines sysibm.sysprint or stem oo (if not '')
into session.sysprint with prefix pref
if opt='b' before existing rows, otherwise after ---------------*/
sysprintInsert: procedure expose m.
parse arg oo, pref, opt
call sqlPreAllCl 12, 'select count(*), min(seqNO), max(seqNo)',
'from session.sysPrint', spr,
, ':cnt, :min :minI, :max :maxI'
call dbg 'sysprint count' cnt 'min' min minI 'max' max maxI
if oo <> '' then do
call sqlPrepare 5,"insert into session.sysPrint values (?, ?)"
if opt = 'b' then
sf = min - m.oo.0
else
sf = max + 1
sq = sf
do ix=1 to m.oo.0
tx = '?'pref || m.oo.ix /* printer vorschub auf pos 1 ||?*/
if length(tx) > 254 then
tx = left(tx, 251)'...'
call sqlExecute 5, sq, tx
sq = sq + 1
end
call dbg 'sysprint insert' oo'.'m.oo.0 'from' sf 'to' (sq-1)
end
else do
call sqlPreAllCl 12, 'select count(*), min(seqNO), max(seqNo)',
'from sysIbm.sysPrint', spr,
, ':sCn, :sMi :sMiI, :sMa :sMaI'
call dbg 'sysibm count' sCn 'min' sMi sMiI 'max' sMa sMaI
if sCn < 1 then
call out 'sysibm.sysprint is empty'
else
call sqlExec "insert into session.sysPrint" ,
"select seqno +" (max+1-sMi) ", text" ,
"from sysibm.sysprint"
end
return
endProcedure sysprintInsert
/***********************************************************************
stored procedure call:
scan parms generate utility and rebind statements
and call dsnUtilU to execeute them
***********************************************************************/
/*--- scan parms, do the work, put output into session.sysprint ------*/
storedProcCall: procedure expose m.
parse arg args
call activateErrHandler
call dbg 'stored Proc call'
res = scanStringRun('-', args)
call errReset 'h'
call globalCleanup
return res
endProcedure storedProcCall
/*--- activate the error handler for the stored proc -----------------*/
activateErrHandler: procedure expose m.
call dbg 'activating err handler'
m.out = 1
call errReset 'h', 'exit(errHandler(ggTxt))'
return
endProcedure activateErrHandler
/*--- stored proc error handler insert error messages
into session.sysprint ----------------------------*/
errHandler: procedure expose m.
parse arg msg
call errReset 'h'
call errSay msg, st, 'e'
do sx=1 to m.st.0
call out m.st.sx
end
say '| inserting output into session.sysprint'
call sysprintInsert out
m.out.0 = 0
/* keine gute Idee, es kommt nur Schrott vom letzten Mal||| ???
say '| insert sysibm.sysprint into session.sysprint'
call sysprintInsert */
say '| globalCleanup'
call globalCleanup
call out '||| error' msg
call out '+++' myTime() 'error exit 12'
say '| inserting output into session.sysprint'
call sysprintInsert out
m.out.0 = 0
say '||| exit(12) |||'
exit(12)
endProcedure errHandler
/*--- connect to pDb, scan src, do the work and
insert output into session.sysprint ---------------------*/
scanStringRun: procedure expose m.
parse arg pDb, src
if pDb <> '' then
call setGlobal 'DB', pDb
if sqlExImm('declare global temporary table sysprint',
'(SEQNO INTEGER NOT NULL,',
'TEXT VARCHAR(254))', -601) = -601 then
call sqlExec 'DELETE FROM SESSION.SYSPRINT', 100
call sqlExec 'set :us = user'
m.superUser = us = 'A695189'
m.explicitTempl = 1
call sqlExec "insert into session.SYSPRINT values",
"(1, '?--- "m.self.name" start'",
"|| ' at" myTime()"'",
"|| ', version " m.self.version"'",
"|| ', db2 member ' || current member)"
call sqlExec "insert into session.SYSPRINT values",
"(2,' sqlUser" strip(us) m.superuser"'",
"|| ', osUser " userid()"')"
call debugSqlCurrent 'scanStringRun db' m.db
call genStatements mCut(gen, 0), src
if m.mapTab ^== '' then
/* das muessen wir vor dem PackageSwitch machen, weil
create statements nur fuer ein Package mit
mit DYNAMICRULES(RUN) erlaubt (sonst SQL -549)
fehlt dem Benutzer die Berechtigung
bekommt er eine Fehlermehldung */
call createMapTab m.mapTab
if pDb = '-' then do
call debugSqlCurrent 'before switch pkg'
call sqlExec "set current packageset = 'DB2ADMIN'"
call debugSqlCurrent 'after switch pkg'
end
cnt = 0
succ = 0
do gx=1 to m.gen.0
if abbrev(m.gen.gx, 'REBIND ') then do
parse var m.gen.gx st '-- ' info
call out '---' st
call out '-- ' info
cnt = cnt + 1
succ = succ + bindCommand(st)
end
else do
call runUtility m.id, m.gen.gx
end
end
if cnt <> succ then
call out '+++' cnt 'rebinds,' (cnt-succ) 'unsuccessful, rc 4'
else if cnt <> 0 then
call out '+++' cnt 'rebinds, all successful, rc 0'
call out "---" myTime() m.self.name "stop"
call sysPrintInsert out
return 0
endProcedure scanStringRun
/*--- connect to pDb, scan src, do the work and
insert output into session.sysprint ---------------------*/
nativeJcl: procedure expose m.
parse arg oo, pDb, src
if pDb <> '' then
call setGlobal 'DB', pDb
call debugSqlCurrent 'nativeJcl db' m.db
m.superuser = -1
m.explicitTempl = 0
call genStatements mCut(gen, 0), src
inReb = 0
step = 0
do gx=1 to m.gen.0
if abbrev(m.gen.gx, 'REBIND ') then do
parse var m.gen.gx st '-- ' info
if ^inReb then do
inReb = 1
step = step + 1
call jclTso oo, "db2 rebind", 'S'step, 0
call mAdd oo, "DSN SYS("m.db")"
end
call mAdd oo, st '-', ' /*' info '*/'
end
else do
inReb = 0
step = step + 1
call mAdd oo,
, left("//*", 50, '-') "db2 utility",
, "//S"step " EXEC PGM=DSNUTILB,REGION=0M,",
|| "PARM=("m.db",'"m.id"')" ,
, "//DSSPRINT DD SYSOUT=*" ,
, "//SYSPRINT DD SYSOUT=*" ,
, "//SYSUDUMP DD SYSOUT=*" ,
, "//UTPRINT DD SYSOUT=*" ,
, "//STPRIN01 DD SYSOUT=*" ,
, "//DUMMY DD DUMMY " ,
, "//SYSTEMPL DD DISP=SHR," ,
|| "DSN="m.db".DBAA.LISTDEF(TEMPL)" ,
, "//SYSIN DD *"
call utilityFormat oo, m.gen.gx
end
end
return 0
endProcedure nativeJcl
jclTso: procedure expose m.
parse arg oo, tit, step, proc
call mAdd oo ,
, left("//*", 50, '-') tit ,
, "//"left(step,9) "EXEC PGM=IKJEFT01,DYNAMNBR=200" ,
, "//SYSTSPRT DD SYSOUT=*" ,
, "//SYSPRINT DD SYSOUT=*"
if proc then
call mAdd oo, "//SYSPROC DD DISP=SHR,DSN=TSO.RZ1.P0.USER.EXEC"
call mAdd oo, "//SYSTSIN DD *"
return oo
endProcedure jclTso
genStatements: procedure expose m.
parse arg gen, src
call mCut c, 0
m.c.list = mCut(l, 0)
call utScanString c, src
call expandLists c
util = utGen(c)
if util = '' then
call out '--- no utility statements generated'
else
call mAdd gen, util
rebCnt = genRebinds(gen, c)
if util = '' & rebCnt = 0 then
call out "+++ nothing to do rc 4"
return
endProcedure genStatements
/*--- scan src, build tasks into stem u ------------------------------*/
utScanString: procedure expose m.
parse arg u, src
call scanSqlReset sc, , 0
call scanSrc sc, src
return utScan(u, sc)
endProcedure ut ScanString
/*--- build tasks into stem u by scanning with sc --------------------*/
utScan: procedure expose m.
parse arg u, sc
m.sc.utilBrackets = 0
utilAll = 'COPY RUNSTATS REBIND LOAD UNLOAD REORG'
gloAll = 'DB ID'
laLi = ''
call scanSqlType sc
do while m.sc.sqlType ^== ''
if utScanList(m.u.list, sc) then do
l = m.u.list
laLi = l'.'m.l.0
call dbg 'new list' laLi 'len' m.laLi.0
do x=1 to m.laLi.0
call dbg x m.laLi.x m.laLi.x.ts
end
end
else if m.sc.sqlType = 'i' ,
& wordPos(m.sc.val, gloAll) > 0 then do
g = m.sc.val
if scanSqlQuId(sc) then
call setGlobal g, m.sc.val
else if scanLit(sc, '-') then
call setGlobal g, '-'
else
call scanErr sc, 'qual id excpected after' g
call scanSqlType sc
end
else if m.sc.sqlType = 'i' ,
& pos(' 'm.sc.val, ' 'utilAll) > 0 then do
uw = word(substr(utilAll, pos(' 'm.sc.val, ' 'utilAll)), 1)
nd = mAdd(u, uw)
m.nd.util = uw
m.nd.shrlevel = 'C'
m.nd.delims = ''
m.nd.limit = ''
m.nd.list = laLi
if laLii = '' then
call scanErr sc, m.nd.util 'without list'
if uw = 'LOAD' | uw = 'UNLOAD' then do
if ^ scanVerify(scanSkip(sc), ' ', 'm') then
call scanErr sc, 'load file dsn expected'
m.nd.loadfile = m.sc.tok
m.nd.0 = 0
end
if uw = 'UNLOAD' then do
if ^ scanVerify(scanSkip(sc), ' ', 'm') then
call scanErr sc, 'punch file dsn expected'
m.nd.punchfile = m.sc.tok
end
call scanSqlType scanSkip(sc)
call utScanOpts nd, sc
end
else if m.sc.sqlType = 'i' & m.sc.val = 'INTO' then do
if m.nd.util <> 'LOAD' then
call scanErr sc, 'into must be in LOAD'
if ^ scanSqlQuID(sc) then
call scanErr 'table name expected'
in = mAdd(nd, m.sc.val)
m.in.tbQu = m.sc.tok
nx = scanUtil(sc)
call scanBack sc, m.sc.tok
m.in.flds = ''
if nx = '(' then do
m.in.flds = '(' scanUtilValue(sc, 0) ')'
call scanSqlType sc
end
end
else if m.sc.sqlType = 'i' & m.sc.val = 'DELIMITED' then do
if m.nd.util <> 'LOAD' & m.nd.util <> 'UNLOAD' then
call scanErr sc, 'delimited must be in LOAD or UNLOAD'
call scanSqlType sc
m.nd.delims = 'DELIMITED COLDEL' delWo(sc) ,
'CHARDEL' delWo(sc) 'DECPT' delWo(sc)
end
else do
call scanErr sc, 'list or' utilAll 'excpected'
end
end
return 1
endProcedure utScan
/*--- scan a word for delimiter syntax -------------------------------*/
delWo: procedure expose m.
parse arg sc
if m.sc.sqlType ^== 's' then
call scanErr sc, "delimiter expected (',' or x'25')"
res = m.sc.tok
call scanSqlType sc
return res
endProcedure delWo
/*--- if the scanner is at a list, scannit and add it to l -----------*/
utScanList: procedure expose m.
parse arg l, sc
listAll = 'TB TS VW'
if m.sc.sqlType ^== 'i' | wordPos(m.sc.val, listAll) < 1 then
return 0
nl = mCut(mAdd(l, 'list'), 0)
do while m.sc.sqlType == 'i' & wordPos(m.sc.val, listAll) > 0
ty = m.sc.val
do forever
if ^ quMask(sc) then
call scanErr sc, 'qualified id for' ty 'expected'
name = m.sc.val
call scanSqlType sc
pa = ''
if m.sc.sqlType = '*' then do
pa = '*'
call scanSqlType sc
end
else do while m.sc.sqlType = 'n'
pa = pa m.sc.val
call scanSqlType sc
if m.sc.sqlType = '-' then do
call scanSqlType sc
if m.sc.sqlType ^== 'n' then
call scanErr sc, 'number expected after -'
pa = pa'-'m.sc.val
call scanSqlType sc
end
else if m.sc.sqlType = 'n' & abbrev(m.sc.val,'-')then do
pa = pa || m.sc.val
call scanSqlType sc
end
end
n1 = mAdd(nl, ty)
m.n1.ts = name
m.n1.parts = pa
if m.sc.sqlType ^== ',' then
leave
end
end
return 1
endProcedure utScanList
/*--- scan a qualifier with mask characters (* ?) --------------------*/
quMask: procedure expose m.
parse arg sc
old1 = m.sc.scanName1
oldR = m.sc.scanNameR
m.sc.scanName1 = old1'*?%_\'
m.sc.scanNameR = oldR'*?%_\'
res = scanSqlQuId(sc)
m.sc.scanName1 = old1
m.sc.scanNameR = oldR
return res
endProcedure quMask
/*--- scan options an put them into u --------------------------------*/
utScanOpts: procedure expose m.
parse arg u, sc
optsAll = ' SHRLEVEL LIMIT RESUME '
do forever
px = pos(' 'm.sc.val, optsAll)
if m.sc.sqlType ^== 'i' | px < 1 then
return 0
if px = pos(' 'm.sc.val, optsAll, px+2) > 0 then
call scanErr sc, 'abbreviation not unique' m.sc.val
att = word(substr(optsAll, px), 1)
if ^ scanSqlType(sc) & pos(m.sc.sqlType, 'in') < 1 then
call scanErr sc, 'value expected for' att
m.u.att = m.sc.val
call scanSqlType sc
end
return
endProcedure utScanOpts
/***********************************************************************
expand lists. query db2Catalog to expand wildcards
***********************************************************************/
/*--- expand all lists -----------------------------------------------*/
expandLists: procedure expose m.
parse arg c
lstLst = m.c.list
do cx = 1 to m.c.0
src = m.c.cx.list
if symbol('st.src') = 'VAR' then do
m.src.list = st.src
iterate
end
trg = mCut(mAdd(lstLst, 'expList' src), 0)
st.src = trg
m.src.list = trg
if m.explicitTempl then
call out ' list' cx
do sx=1 to m.src.0
call expandAdd trg, m.src.sx, m.src.sx.ts, m.src.sx.parts
end
end
return
endProcedure expandLists
/*--- expand one list entry and add the results to lst ---------------*/
expandAdd: procedure expose m.
parse arg lst, ty, qu '.' na, pa
if m.explicitTempl then
call out ' expanding' ty qu'.'na pa
/* build the sql */
sqS = 'select distinct strip(t.creator), strip(t.name),',
'strip(t.dbName), strip(t.tsName),',
's.partitions, s.nTables' ,
'from sysIbm.sysTables t, sysIbm.sysTablespace s'
sqW = 'where t.tsName = s.name and t.dbName = s.dbName',
"and t.type = 'T'"
if ty = 'TS' then
sq = sqS sqW 'and t.dbName' sqlClause(qu) ,
'and t.tsName' sqlClause(na)
else if ty = 'TB' then
sq = sqS sqW 'and t.creator' sqlClause(qu) ,
'and t.name' sqlClause(na)
else if ty = 'VW' then
sq = "with pa (cre, nam, typ, lev) as" ,
"( select bCreator, bName, bType, 1" ,
"from sysibm.sysViewDep" ,
"where dType = 'V'" ,
"and dCreator" sqlClause(qu) ,
"and dName" sqlClause(na) ,
"union all select d.bCreator, d.bName," ,
"d.bType, p.lev+1" ,
"from sysibm.sysViewDep d, pa p" ,
"where d.dcreator = p.cre and d.dName = p.nam" ,
"and d.dType = p.Typ and p.lev < 1000" ,
")" sqS ", pa p" sqW ,
"and p.typ = 'T' and p.cre = t.creator" ,
"and p.nam = t.name"
else
call err 'bad list type' ty 'for' qu'.'na pa
call dbg 'exp sql' sq
call sqlPreOpen 1, sq
xOld = m.lst.0
do x=xOld+1 by 1 /* fetch the result rows */
z = lst'.' || x
y = ':m.'z'.'
if ^ sqlFetchInto(1, y'CR,' y'TB,',
y'db,' y'ts,' y'paCnt,' y'tbCnt') then
leave
ky = m.z.cr'.'m.z.tb
/* check authorization */
if m.superuser == -1 then do
m.auth.ky = ''
end
else if symbol('m.auth.ky') ^== 'VAR' then do
aa = 'delete from' ky
if sqlExec('prepare s9 from :aa', '0 -551') = 0 then do
m.auth.ky = 'w'
end
else do
m.auth.ky = 'r' sqlMsg()
call dbg 'no auth w' ky m.auth.ky
aa = 'select 1 from' ky
if sqlExec('prepare s9 from :aa', '0 -551') = -551 then
m.auth.ky = '-' sqlMsg()
end
end
m.z.auth = m.auth.ky
if m.explicitTempl | m.debug then
call out ' ts' m.z.db'.'m.z.ts',' m.z.paCnt 'parts,' ,
m.z.tbCnt 'tables:' ky', auth' m.z.auth
m.z.parts = pa
call dbg 'llll' z m.z.auth parts m.z.parts
end
m.lst.0 = x-1
call sqlClose 1
call dbg 'fetched' m.lst.0 - xOld
return
endProcedure expandAdd
/*--- return a sql clause = val, like val, like val escape -----------*/
sqlClause: procedure expose m.
parse arg val
if verify(val, '*?', 'm') < 1 then
return '=' quote(val, "'")
else if verify(val, '_%', 'm') < 1 then
return 'like' quote(translate(val, '%_', '*?'), "'")
call dbg 'sql val before' val
cx = -1
do while cx < length(val)
cx = verify(val, '\_%', 'm', cx+2)
if cx < 1 then
leave
val = left(val, cx-1)'\'substr(val, cx)
end
val = translate(val, '%_', '*?')
call dbg 'sql val after ' val
return 'like' quote(val, "'") "escape '\'"
endProcedure sqlClause
/***********************************************************************
generate utility statements
***********************************************************************/
/*--- generate all utility statements --------------------------------*/
utGen: procedure expose m.
parse arg utSt
st = ''
do ux=1 to m.utSt.0
u = utSt'.'ux
if m.u.util = 'COPY' then
st = st utCopy(u)
else if m.u.util = 'LOAD' then
st = st utLoad(u)
else if m.u.util = 'RUNSTATS' then
st = st utRunstats(u)
else if m.u.util = 'UNLOAD' then
st = st utUnload(u)
else if m.u.util = 'REORG' then
st = st utReorg(u)
else if wordPos(m.u.util, 'REBIND') < 1 then
call err 'utility' m.u.util 'not implemented (yet)'
end
return st
endProcedure utGen
/*--- generate copy --------------------------------------------------*/
utCopy: procedure expose m.
parse arg u
listDef = utListDef(m.u.list, 1, 'r')
if listDef = '' then do
call out '+++ copy on empty list, rc 4'
return ''
end
tCo = utTemplate('COPYD')
st = subword(tCo, 2)
st = st subword(listdef, 2) ,
'COPY LIST' word(listdef, 1),
'COPYDDN('word(tCo, 1)') FULL YES PARALLEL' m.cnf.lf,
'SHRLEVEL' word('REFERENCE CHANGE',
, 2 - abbrev(m.c.shrLevel, 'R'))
return st m.cnf.eSt
endProcedure utCopy
/*--- generate runstats ----------------------------------------------*/
utRunstats: procedure expose m.
parse arg u
listDef = utListDef(m.u.list, 0, 'w')
if listDef = '' then do
call out '+++ runstats on empty list, rc 4'
return ''
end
st = subword(listdef, 2) ,
'RUNSTATS TABLESPACE LIST' word(listdef,1),
'INDEX(ALL) UPDATE(ALL) SHRLEVEL CHANGE'
return st m.cnf.eSt
endProcedure genRunstats
/*--- generate unload ------------------------------------------------*/
utUnload: procedure expose m.
parse arg u
ll = m.u.list
listDef = utListDef(ll, 0, 'w', 'tbCnt')
ll = m.ll.list
if m.ll.0 < 1 then do
call out '+++ unload on empty list, rc 4'
return ''
end
tLo = utTemplate('LOAD', m.u.loadFile)
tPu = utTemplate('PUNCH', m.u.punchFile)
st = subword(tLo,2) subword(tPu, 2)
do lx = 1 to m.ll.0
st = st 'UNLOAD DATA FROM TABLE' m.ll.lx.cr'.'m.ll.lx.tb
if m.u.limit <> '' then
st = st 'LIMIT' m.u.limit
st = st m.cnf.lf,
'UNLDDN' word(tLo, 1) m.cnf.lf,
'PUNCHDDN' word(tPu, 1) m.cnf.lf,
m.u.delims utShr(m.u.shrlevel) m.cnf.eSt
end
return st
endProcedure utUnload
/*--- generate load --------------------------------------------------*/
utLoad: procedure expose m.
parse arg u
ll = m.u.list
listDef = utListDef(ll, 1, 'w', 'tbCnt')
ll = m.ll.list
if m.ll.0 < 1 then do
call out '+++ load on empty list, rc 4'
return ''
end
tCo = utTemplate('COPYD')
tLo = utTemplate('LOAD', m.u.loadFile)
tWo = utTemplate('WORKDDN')
st = subword(tLo, 2) subword(tCo, 2) subword(tWo, 2)
if abbrev('YES', m.u.resume) then
rere = 'RESUME YES' utshr(m.u.shrlevel)
else if abbrev('NO', m.u.resume) then
rere = 'RESUME NO REPLACE COPYDDN' word(tCo, 1)m.cnf.lf,
'STATISTICS INDEX ALL UPDATE ALL'
else
call err 'bad resume' m.u.resume
do lx = 1 to m.ll.0
st = st 'LOAD INDDN' word(tLo, 1) rere m.cnf.lf ,
word(tWo, 1) m.cnf.lf
if m.u.delims <> '' then
st = st 'FORMAT' m.u.delims
crTb = m.ll.lx.cr'.'m.ll.lx.tb
do ix = 1 to m.u.0 until m.u.ix = crTb
end
if ix > m.u.0 then do
st = st 'INTO TABLE' crTb
end
else do
in = u'.'ix
st = st 'INTO TABLE' m.in.tbQu
if m.in.flds <> '' then
st = st m.cnf.lf m.in.flds
end
st = st m.cnf.eSt
end
return st
endProcedure utLoad
/*--- generate Reorg -------------------------------------------------*/
utReorg: procedure expose m.
parse arg u
listDef = utListDef(m.u.list, 0, 'w')
mt = m.id
if pos('.', mt) > 0 then
mt = left(mt, pos('.', mt) - 1)
if mt = '' then
call err 'bad utility id' m.id 'gives empty mapTab'
m.mapTab = 'S100447.'mt
if listDef = '' then do
call out '+++ reorg on empty list, rc 4'
return ''
end
st = ''
tCo = utTemplate('COPYD')
tRe = utTemplate('SRECD')
tWo = utTemplate('WORKDDN')
st = subword(tCo, 2) subword(tRe, 2) subword(tWo, 2)
st = st subword(listdef, 2) ,
'REORG TABLESPACE LIST' word(listdef, 1) m.cnf.lf,
'LOG NO SORTDATA NOSYSREC SORTKEYS' m.cnf.lf,
'COPYDDN('word(tCo, 1)')'m.cnf.lf,
'SHRLEVEL CHANGE' m.cnf.lf,
'DRAIN_WAIT 1800 RETRY 0 RETRY_DELAY 300'm.cnf.lf,
'MAPPINGTABLE' m.mapTab m.cnf.lf,
'MAXRO 120 DRAIN WRITERS LONGLOG CONTINUE' m.cnf.lf,
'DELAY 1200 TIMEOUT TERM' m.cnf.lf,
'UNLDDN('word(tRe, 1)')' m.cnf.lf,
word(tWo, 1) 'SORTDEVT DISK SORTNUM 48' m.cnf.lf,
'STATISTICS INDEX ALL KEYCARD REPORT NO' m.cnf.lf,
'UPDATE ALL HISTORY NONE FORCEROLLUP NO'
return st m.cnf.eSt
endProcedure utReorg
/*--- Create Mappingtable für Reorg if necessary
Mappintable heisst S100447.name in DB2MAPUT.name -------*/
createMaptab: procedure expose m.
parse upper arg cr '.' name
if sqlPreAllCl(5,'SELECT 1',
'FROM SYSIBM.SYSTABLES' ,
"WHERE CREATOR = '"cr"'" ,
"AND NAME = '"NAME"' AND TYPE = 'T'",
, st , ':haha') > 0 then
return cr'.'name
call sqlCommit /* sonst ist nach rollback session.sysprint weg */
call debugSqlCurrent 'before switch sql'
sc = sqlExec("set current sqlid = 'S100447'", '*')
call debugSqlCurrent 'after switch sql'
if sc = 0 then
if sqlExec('CREATE DATABASE DB2MAPUT',
'BUFFERPOOL BP2',
'INDEXBP BP1',
'CCSID EBCDIC',
'STOGROUP GSMS',
, '*') = -601 then /* wenn vorhanden, dann ok */
sc = 0
/* Tablespace für Maptab */
if sc = 0 then
sc = sqlExec('CREATE TABLESPACE' name,
'IN DB2MAPUT',
'USING STOGROUP GSMS',
'PRIQTY 12 SECQTY 48',
'ERASE NO ',
'FREEPAGE 0 PCTFREE 5',
'GBPCACHE CHANGED',
'TRACKMOD YES ',
'SEGSIZE 64 ',
'BUFFERPOOL BP2 ',
'LOCKSIZE ANY ',
'LOCKMAX SYSTEM ',
'CLOSE YES ',
'COMPRESS NO ',
'CCSID EBCDIC',
'DEFINE YES ',
'MAXROWS 255',
, '*')
/* Mappingtable anlegen */
if sc = 0 then
sc = sqlExec( 'CREATE TABLE' cr'.'name,
'("TYPE" CHAR(1) FOR SBCS DATA NOT NULL,',
'SOURCE_RID CHAR(5) FOR SBCS DATA NOT NULL,',
'TARGET_XRID CHAR(9) FOR SBCS DATA NOT NULL with default,',
'LRSN CHAR(6) FOR SBCS DATA NOT NULL)',
'IN DB2MAPUT.'name ' audit none ccsid ebcdic not volatile',
, '*')
if sc = 0 then
sc = sqlExec('CREATE UNIQUE INDEX' cr'.I'name,
'ON' cr'.'name,
'(SOURCE_RID ASC,',
' "TYPE" ASC,',
'TARGET_XRID ASC,',
'LRSN ASC)',
'USING STOGROUP GSMS',
'PRIQTY -1 SECQTY -1',
'ERASE NO',
'FREEPAGE 0 PCTFREE 10',
'GBPCACHE CHANGED',
'NOT CLUSTER',
'CLOSE YES',
'COPY NO',
'DEFINE YES',
'PIECESIZE 2 G',
, '*')
if sc = 0 then do
call sqlCommit
return cr'.'name
end
call out ' '
call out '+++ Sie haben keine Berechtigung,'
call out '+++ die Mappingtable' cr'.'name 'zu erstellen'
call out '+++ bitte wenden Sie sich an die Db2 Administration'
call out ' '
call out sqlMsg()
call sqlExec 'rollback'
call err 'Berechtigung fuer MappgingTable'
endProcedure createMaptab
/*--- generate listdef -----------------------------------------------*/
utListDef: procedure expose m.
parse arg l, allParts, necAuth, checks
call dbg 'utListDef' l '-->' m.l.list
l = m.l.list
if m.l.0 = 0 then
return ''
if symbol('m.listdef') == 'VAR' then
m.listdef = m.listdef + 1
else
m.listdef = 1
st = 'LIST'm.listdef
st = st 'LISTDEF' st
if pos('tbCnt', checks) > 0 then do
do x=1 to m.l.0
if m.l.x.tbCnt <> 1 then
call err 'nur 1 table unterstuetzt, nicht' m.l.x.tbCnt,
'in ts' m.l.x.db'.'m.l.x.ts,
'mit table' m.l.x.cr'.'m.l.x.tb
end
end
do x=1 to m.l.0
aa = word(m.l.x.auth, 1)
if m.superUser == -1 then
nop
else if wordPos(necAuth || aa, 'ww rw rr') > 0 then
call dbg 'auth' necAuth 'allowed for' ,
m.l.x.cr'.'m.l.x.tb 'in' m.l.x.db'.'m.l.x.ts aa
else if m.superUser == 1 then
call out 'ignoring authorization' necAuth 'for',
m.l.x.cr'.'m.l.x.tb 'in' m.l.x.db'.'m.l.x.ts m.l.x.auth
else
call err 'authorization' necAuth 'error for',
m.l.x.cr'.'m.l.x.tb 'in' m.l.x.db'.'m.l.x.ts m.l.x.auth
st = st m.cnf.lf 'INCLUDE TABLESPACE' m.l.x.db'.'m.l.x.ts
if ^ abbrev('*', m.l.x.parts) then
st = st 'PARTLEVEL' m.l.x.parts
else if allParts then
st = st 'PARTLEVEL'
end
return st m.cnf.eSt
endProcedure utListDef
/*--- generate shrlevel ----------------------------------------------*/
utShr: procedure expose m.
parse arg lv, opt
if abbrev('CHANGE', lv) then
return 'SHRLEVEL CHANGE'
if abbrev('REFERENCE', lv) then
return 'SHRLEVEL REFERENCE'
if ^ abbrev('NONE', lv) then
call err 'bad shrLevel' lv
if opt = 1 then
return 'SHRLEVEL NONE'
else
return ''
endProcedure utShr
/*--- generate template ----------------------------------------------*/
utTemplate: procedure expose m.
parse upper arg ty, dsn
nm = 'T'ty
if dsn = '' then do
if m.templ.gen.nm == 1 then
return nm
if ty = 'WORKDDN' then do
u = utTemplate('SYUTD')
s = utTemplate('SOUTD')
return 'WORKDDN('word(u, 1)','word(s, 1)')' ,
subword(u, 2) subword(s, 2)
end
m.templ.gen.nm = 1
end
else if dsn = 'DUMMY' then do
return DUMMY
end
else do
dsn = "DSN('"dsn"')"m.cnf.lf
nm = nm || mInc(templ.0)
end
m.templ.name = nm
if wordPos(ty, 'COPYD SYUTD SOUTD SRECD') < 1 then
return nm 'TEMPLATE' nm dsn m.templ.new m.cnf.eSt
else if m.explicitTempl then
return nm 'TEMPLATE' nm dsn m.templ.ty m.cnf.eSt
else
return nm
endProcedure utTemplate
/*--- run utility with the given stamtents and write output ----------*/
runUtility: procedure expose m.
parse arg utId, st
call scanUtilReset xxx
call out ''
call out '--- utility statements'
call utilityFormat , st
st = translate(st, ' ', m.cnf.lf)
call dbg 'util st' length(st)':' st
rst = 'NO'
retcode = -9876
e = ''
z = 0
call out
call out '---' myTime() "exec sql call" m.cnf.procSys "("utId",...)"
src = "call" m.cnf.procSys"( :utId, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
if m.debug == 1 then do
call debugSqlCurrent 'before sql' src
call dbg ' with utId' utId
call dbg ' with rst' rst
call dbg ' with st' st
call dbg ' with e' e
call dbg ' with z' z
end
call sqlExec src, 0 +466
call out '---' myTime() 'utility retCode' retCode
call out '--- utility output'
call sysPrintInsert out
m.out.0 = 0
call sysPrintInsert
call out '--- end utility output'
call out '+++' myTime() 'utility retCode' retCode
call sysPrintInsert out
m.out.0 = 0
return
endProcedure runUtility
/*--- write the utility statements in st
formated in lines to stem oo -------------------------------*/
utilityFormat: procedure expose m.
parse arg oo, st
call scanUtilReset xxx
x = 0
cont = 0
do while x < length(st)
y = pos(m.cnf.lf, st, x+1)
if y = 0 then
y = length(st) + 1
li = strip(substr(st, x+1, y-x-1))
cont = wordPos(word(li, 1), m.scanUtil) < 1
if oo = '' then
call out left('', 4 * cont)li
else
call mAdd oo, left('', 4 * cont)li
x = y
end
return
endProcedure utilityFormat
/***********************************************************************
rebinds
***********************************************************************/
/*--- all rebinds ----------------------------------------------------*/
doRebind: procedure expose m.
parse arg utSt
oldDb = ''
sel = ''
do ux=1 to m.utSt.0
u = utSt'.'ux
if m.u.util ^= 'REBIND' then
iterate
gotRebind = 1
l = m.u.list
listDef = utListDef(l, 0, 'w') /* check authorization */
call dbg 'list' l m.l.0
l = m.l.list
do lx=1 to m.l.0
call dbg 'rebind tb' m.l.lx.cr'.'m.l.lx.tb
if oldDb <> m.l.lx.DB then do
oldDb = m.l.lx.DB
sel = sel ")) or (bQualifier='"oldDb"' and bName in ('"
end
else do
sel = sel", '"
end
sel = sel || m.l.lx.ts"'"
call dbg 'sel +' sel
end
end
if sel = '' then do
if gotRebind = 1 then
call out '+++ no rebinds for empty object list, rc 4'
return 0
end
sel = substr(sel, 7)'))'
call dbg 'sel =' sel
p = ':m.pk.sx.'
call sqlPreOpen 8,
, "select distinct dCollid, dName, dContoken, version, p.type,",
"p.bindTime, p.valid, p.operative",
"from sysibm.sysPackDep d, sysibm.sysPackage p" ,
"where bType in ('P', 'R')" ,
"and d.dLocation = p.location" ,
"and d.dCollid = p.collid" ,
"and d.dName = p.name" ,
"and d.dConToken = p.conToken" ,
"and ("sel")" ,
"order by 2, 4, 1"
succ = 0
do sx=1 while sqlFetchInto(8, ':col, :nam, :cTo, :ver, :typ,' ,
':bTi, :val, :ope')
call dbg sx col nam c2x(cTo) ver typ bTi 'vo' val ope
st = 'PACKAGE('strip(col)'.'strip(nam)
if typ = 'T' then
st = 'REBIND TRIGGER' st')'
else
st = 'REBIND' st'.('strip(ver)'))'
call out '---' st
call out '-- valid='val', op='ope', lastBind='bTi
succ = succ + bindCommand(st)
end
call sqlClose 8
sx = sx-1
if sx = succ then
call out '+++' sx 'rebinds, all successful, rc 0'
else
call out '+++' sx 'rebinds,' (sx-succ) 'unsuccessful, rc 4'
return sx
endProcedure doRebind
genRebinds: procedure expose m.
parse arg gen, utSt
oldDb = ''
sel = ''
do ux=1 to m.utSt.0
u = utSt'.'ux
if m.u.util ^= 'REBIND' then
iterate
gotRebind = 1
l = m.u.list
listDef = utListDef(l, 0, 'w') /* check authorization */
call dbg 'list' l m.l.0
l = m.l.list
do lx=1 to m.l.0
call dbg 'rebind tb' m.l.lx.cr'.'m.l.lx.tb
if oldDb <> m.l.lx.DB then do
oldDb = m.l.lx.DB
sel = sel ")) or (bQualifier='"oldDb"' and bName in ('"
end
else do
sel = sel", '"
end
sel = sel || m.l.lx.ts"'"
call dbg 'sel +' sel
end
end
if sel = '' then do
if gotRebind = 1 then
call out '+++ no rebinds for empty object list, rc 4'
return 0
end
sel = substr(sel, 7)'))'
call dbg 'sel =' sel
p = ':m.pk.sx.'
call sqlPreOpen 8,
, "select distinct dCollid, dName, dContoken, version, p.type,",
"p.bindTime, p.valid, p.operative",
"from sysibm.sysPackDep d, sysibm.sysPackage p" ,
"where bType in ('P', 'R')" ,
"and d.dLocation = p.location" ,
"and d.dCollid = p.collid" ,
"and d.dName = p.name" ,
"and d.dConToken = p.conToken" ,
"and ("sel")" ,
"order by 2, 4, 1"
succ = 0
do sx=1 while sqlFetchInto(8, ':col, :nam, :cTo, :ver, :typ,' ,
':bTi, :val, :ope')
call dbg sx col nam c2x(cTo) ver typ bTi 'vo' val ope
st = 'PACKAGE('strip(col)'.'strip(nam)
if typ = 'T' then
st = 'REBIND TRIGGER' st')'
else
st = 'REBIND' st'.('strip(ver)'))'
call mAdd gen, st '-- valid='val', op='ope', lastBind='bTi
end
call sqlClose 8
return sx - 1
endProcedure genRebinds
/*--- one bindstatement ----------------------------------------------*/
bindCommand: procedure expose m.
parse arg stmt
/****** use undocumented DSNESM71 programm,
as it is used in DSNTBIND ***********************************/
'NEWSTACK'
queue "DSNE"
queue stmt
queue "END"
x = outtrap('m.bm.')
ADDRESS ATTCHMVS "DSNESM71" /* call "pre" bind */
bind_rc = rc /* set rc to DSNESM71 call */
x = outtrap('OFF')
'DELSTACK'
call dbg 'bind rc' bind_rc D2X(ABS(bind_rc)) 'msgs' m.bm.0
call sysPrintInsert out
m.out.0 = 0
if m.debug then do x=1 to m.bm.0
call dbg m.bm.x
end
call sysPrintInsert bm
do bx = 1 to m.bm.0
if pos(' SUCCESSFUL REBIND ', m.bm.bx) > 0
then return 1
end
return 0
endProcedure bindCommand
/***********************************************************************
small helper functions
***********************************************************************/
/*--- one output message ---------------------------------------------*/
out: procedure expose m.
parse arg 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
say substr(msg, bx+2, ex-bx-2)
if m.out then
call mAdd out, substr(msg, bx+2, ex-bx-2)
bx = ex
end
return
endProcedure out
/*--- one debug message ----------------------------------------------*/
dbg: procedure expose m.
parse arg msg
if m.debug then
call out '???' msg
return
endProcedure dbg
/***********************************************************************
old test functions
***********************************************************************/
autTest: procedure expose m.
call setGlobal 'DB', 'DBAF'
call sqlExec 'set :oldPkgSet = current packageset'
call out '*** autTest oldPkgSet =' oldPkgSet
call autTestOne 'DSNREXX'
call autTestOne 'DSNREXCS'
call autTestOne 'DSNREXRR'
call autTestOne 'DSNREXRS'
call autTestOne 'DSNREXUR'
call autTestOne 'DB2ADMIN'
call sqlExec 'set current packageset = :oldPkgSet'
call sqlExec 'set :act = current packageset'
call out '*** autTest switche back to PkgSet =' act
return 0
endProcedure autTest
autTestOne: procedure expose m.
parse arg pkgSet
call sqlExec 'set current packageset = :pkgSet'
call sqlExec 'set :act = current packageset'
call out '*** autTestOne with pkgSet' pkgSet '=' act
se = 'select WK011CH20 from A540769A.TWK011A'
call autTestSel se
call autTestSel se 'where 1 = 0'
up = "update A540769A.TWK011A set WK011CH2 = 'q'"
call autTestUpd up
call autTestUpd up 'where 1 = 0'
return
endProcedure autTestOne
autTestSel: procedure expose m.
parse arg sel
msg = ''
if sqlExec('prepare s7 from :sel', '*') < 0 then
msg = 'prepare' sqlMsg()
if sqlExec('declare c7 cursor for s7', '*') < 0 & msg = '' then
msg = 'declare' sqlMsg()
if sqlExec('open c7', '*') < 0 & msg = '' then
msg = 'open' sqlMsg()
v=''
fet = sqlExec('fetch c7 into :v', '*')
if fet < 0 msg = '' then
msg = 'fetch v='v sqlMsg()
if sqlExec('close c7', '*') < 0 then
msg = 'close' sqlMsg()
if msg = '' then
msg = 'sel ok fet' fet 'v' v
else
msg = 'sel err fet' fet
call out msg sel
return
endTestSel
autTestSelOld: procedure expose m.
parse arg sel
call out 'autTestSel' sel
call sqlExec 'prepare s7 from :sel', '*'
call out ' prepare' sqlMsg()
call sqlExec 'declare c7 cursor for s7', '*'
call out ' declare' sqlMsg()
call sqlExec 'open c7', '*'
call out ' open' sqlMsg()
v=''
call sqlExec 'fetch c7 into :v', '*'
call out ' fetch v='v sqlMsg()
call sqlExec 'close c7', '*'
call out ' close' sqlMsg()
return
endTestSelOld
autTestUpd: procedure expose m.
parse arg upd
msg = ''
if sqlExec('prepare s1 from :upd', '*') < 0 then
msg = 'prep' sqlMsg()
if sqlExec('execute s1', '*') < 0 & msg = '' then
msg = 'exec' sqlMsg()
if msg = '' then
msg = 'ok'
call out 'upd' msg
return
endTestUpd
autTestUpdOld: procedure expose m.
parse arg upd
call out 'autTestUpd' upd
call sqlExec 'execute immediate :upd', '*'
call out ' execute immediate' sqlMsg()
return
endTestUpdOld
debugSqlCurrent: procedure expose m.
parse arg pr, always
if m.debug ^== 1 & always ^== 1 then
return
call sqlPreAllCl 5,'SELECT current sqlid, user, current packageset',
'from sysibm.sysDummy1' , st , ':id, :us, :pa'
if m.st.0 <> 1 then
call err 'sysDummy1 <> 1'
call out pr 'sqlCurrent sqlId' id 'user' us 'pkgSet' pa
return
endProcedure debugSqlCurrent
/*--- return current collection --------------------------------------*/
testAnaPunch: procedure expose m.
call errReset 'h'
call analysePunch p1, 'DBAF.TMP.TST.DA540769.A418A.PUN3'
say 'tb' m.p1.tb '*' m.p1.tbQu
say ' inDsn' m.p1.inDsn
say ' flds' m.p1.flds
return 0
endProcedure testAnaPunch
testmaptab: procedure expose m.
call errReset 'h'
call sqlconnect dbaf
call sqlExec "set current sqlid = 'S100447'"
call createMaptab 's100447.Walter2'
call sqldisconnect
return 0
endProcedure testmaptab
testCopy1: procedure expose m.
call activateErrHandler
call setGlobal 'DB', 'DBAF'
m.l.1.ts = 'DGDB9998.A422A'
m.l.1.parts = '*'
m.l.0 = 1
m.c.0 = 1
c = 'C.1'
m.c.util = 'COPY'
m.c.list = l
c = 'C'
call runUtility m.id, utGen(c)
/* call err 'test errhandler\nline2\nline3 |' */
call outputSysprint
m.c.1.util = 'RUNSTATS'
call runUtility m.id, utGen(c)
call outputSysprint
call globalCleanup
return 0
endProcedure testCopy1
testCopy2: procedure expose m.
call activateErrHandler
call scanStringRun 'DBAF', 'ts DGDB9998.A422A 4 - 8 11 12 -18',
'id A540769.test2 copy shr r'
call outputSysprint
call globalCleanup
return 0
endProcedure testCopy2
testCopy3: procedure expose m.
call activateErrHandler
call scanStringRun 'DBAF', 'ts DGDB9998.A202A ',
'id A540769.test2 copy shr r run'
call outputSysprint
call globalCleanup
return 0
endProcedure testCopy2
testRebind: procedure expose m.
c = 'REBIND PACKAGE(DB.DBWK3.(DB2J000003))'
c = '-DIS DATABASE(DA540769)'
b = 'REBIND PACKAGE(DB.DBWK1.(DB2J000003))'
c = 'REBIND PACKAGE(DB.DBWK3.(DB2J000003))'
d = 'REBIND PACKAGE(DB.DBWK411.(DB2J000003))'
call bindCommand b
return 0
db2Command: procedure expose m.
parse arg cmd
call dbg 'db2Command' cmd
len = length(cmd)
e = ''
cCmd = -99
iRet = -99
iRes = -99
xsBy = -99
gRea = -99
gXs = -99
cRc = -99
cMsg = left('', 6000)
cMsgI = -123
sql = "CALL SYSPROC.ADMIN_COMMAND_DB2(" ,
":cmd," ,/* DB2_CMD P 1 VARCHAR */
":len," ,/* LEN_CMD P 2 INTEGER */
":e," ,/* PARSE_TYPE P 3 VARCHAR */
":e," ,/* DB2_MEMBER P 4 VARCHAR */
":cCmd," ,/* CMD_EXEC O 5 INTEGER */
":iRet," ,/* IFCA_RET O 6 INTEGER */
":iRes," ,/* IFCA_RES O 7 INTEGER */
":xsBy," ,/* XS_BYTES O 8 INTEGER */
":gRea," ,/* IFCA_GRES O 9 INTEGER */
":gXs," ,/* GXS_BYTES O 10 INTEGER */
":cRc," ,/* RETURN_CODE O 11 INTEGER */
":cMsg :cMsgI" ,/* MSG O 12 VARCHAR */
")"
call dbg 'db2Cmd sql' sql
sc = sqlExec(sql, 466)
call dbg 'cmd sqlCode' sc 'cCmd' cCmd 'ret' iRet
call dbg 'msg ind' cMsgI 'len' length(cMsg) length(strip(cMsg))
call sqlPreOpen 1, 'select rowNum, text' ,
'from sysibm.db2_cmd_output' ,
'order by 1 asc'
do while sqlFetchInto(1, ':rw, :tx', 100)
call dbg 'cmd' rw strip(tx, 't')
end
return 0
endProcedure db2Command
testStoredProc: procedure expose m.
parse arg conn
call errReset 'h'
m.out = 1
call scanStringRun conn, 'id A540769A tb gdb6663.TWK401A',
'reo '
/* call scanStringRun conn, 'id A540769.stoPr tb A540769.TWK418A' ,
' loa TSS.SKA.TMP.TST.&TS..UNL3',
' RESU n SHRLEVEL CHANGE LIMIT 89' ,
' delimited '','' X''7F'' ''.'' '
call scanStringRun conn, 'id A540769.stoPr tb OA1A01.TBE111A1 REB'
call scanStringRun conn, 'id A540769.stoPr tb A540769.TWK418A ',
'copy shr r reb'
' LOA DBAF.TMP.TST.DA540769.A418A.LOA3',
' SHRLEVEL CHA resume Y',
' into "A540769"."TWK418A" ( ',
' "WK418K1"',
'\POSITION( 00003:00008) CHAR(00006)',
'\, "WK418K2"',
'\POSITION( 00009:00012) CHAR(00004)',
'\, "WK418D1"',
'\POSITION( 00014:00015) CHAR(00002)',
"\ NULLIF(00013)=X'FF')"
'copy shr r rebi'
' tb *.AB?T_T* ' ,
' tb A540769.TWK411A1 TB OA1A.TMF716A1' ,
' vw GDB9998.VWK210A2 ' ,
' unl TSS.SKA.TMP.TST.&TS..UNL3',
' TSS.SKA.TMP.TST.&TS..PUN3',
' RESU n SHRLEVEL CHANGE LIMIT 89 RUN',
call scanStringRun conn, 'id A540769.stoPr tb A540769.TWK418A' ,
' unl TSS.SKA.TMP.TST.&TS..UNL3',
' TSS.SKA.TMP.TST.&TS..PUN3',
' RESU n SHRLEVEL CHANGE LIMIT 89',
' delimited '','' X''7F'' ''.'' '
*/
call showSysPrint
return 0
endProcedure testStoredProc
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its type in m.sc.utilType:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilType = left(m.sc.tok, 1)
else
m.sc.utilType = ty
return m.sc.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if ^ m.sc.utilSpace then
v = v || one
else if nl ^== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilType == '' then
return ''
else if m.sc.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilType, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- 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
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
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 ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
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
/*--- 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
call 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
/* copy sql end **************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, rdr, scanWin
if scanWin ^== 0 then
call scanWinReset m, rdr, 5, 2, 1, 72
else
m.m.read = rdr
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.read, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlType(m)
if m.m.sqlType = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlType: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlType = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlType = 's'
if ^abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlType = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlType = 'd'
else
m.m.sqlType = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlType = 'n'
else if scanChar(m, 1) then
m.m.sqlType = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlType = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlType
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br ^== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlType(m) & m.m.sqlType ^== ';'
if m.m.sqlType = '(' then br = br + 1
else if m.m.sqlType ^== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if ^ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if ^ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if ^ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
n = ''
if scanLit(m, '+', '-') then do
n = m.m.tok
if noSp <> 1 then
call scanSpaceNl m
end
if scanLit(m, '.') then
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.m.tok
else if n == '' then
return 0
else if noSp = 1 then do
call scanBack m, n
return 0
end
else
call scanErr m, 'scanSqlNum bad number: no digits after' n
if pos('.', n) < 1 then
if scanLit(m, '.') then do
if scanVerify(m, '0123456789') then
n = n'.'m.m.tok
end
if scanLit(m, 'E', 'e') then do
n = n'E'
if scanLit(m, '+', '-') then
n = n || m.m.tok
if ^ scanVerify(m, '0123456789') then
call scanErr m, 'scanSqlNum bad number: no digits after' n
n = n || m.m.tok
end
if checkEnd ^= 0 then
if pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNum number' n 'bad end' ,
scanLook(m, 1)
m.m.val = n
return 1
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if ^ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | ^ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if ^sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call oDecMethods oNewClass('ScanWin'),
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanClose call scanWinClose m ',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinReset(oNew('ScanWin'), rdr, wiSz, wiBa, cuPo, cuLe)
/*--- set the attributes of window scanner m, open rdr and start read*/
scanWinReset: procedure expose m.
parse arg m, rdr, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.read = rdr
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return scanWinOpen(m)
endProcedure scanWinReset
scanWinOpen: procedure expose m.
parse arg m, lx
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.read, 'r'
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.read
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if ^ jRead(m.m.read, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment ^== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.read = ''
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
call scanIni
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanReset
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.atEnd = 1
m.m.pos = 1
return m
endProcedure scanSrc
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len ^= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok ^== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok ^== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if ^ scanVerify(m, '0123456789') then
return 0
if chEn^==0 & pos(substr(m.m.src, m.m.pos,1), m.m.scanNameR)>0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
scanInt: procedure expose m.
parse arg m, chEn
if scanNat(m, chEn) then
return 1
ox = m.scan.m.pos
if pos(substr(m.scan.m.src, ox, 1) , '+-') < 1 then
return 0
m.scan.m.pos = ox + 1
if | scanNat(m) then do
m.scan.m.pos = ox
return 0
end
m.tok =substr(m.scan.m.src, ox, 1)|| m.tok
return 1
endProcedure scanInt
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.m.key = m.m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.read ^== '' then
interpret 'res = ' oObjMethod(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment ^== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.read ^== '' then
interpret 'return' oObjMethod(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.read == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg"\n" ||' oObjMethod(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
catOpt: procedure
parse arg opt, keep
if abbrev(opt, '<') then
o = 'r'substr(opt, 2)
else if abbrev(opt, '>>') then
o = 'a'substr(opt, 3)
else if abbrev(opt, '>') then
o = 'w'substr(opt, 2)
else if pos(left(opt, 1), 'rwa') > 0 then
o = opt
else
o = '?'opt
if keep ^== 1 then
o = translate(o, ' ', '£#')
return space(o, 0)
endProcedure catOpt
/*--- create and possibly open a reader or writer --------------------*/
catMake: procedure expose m.
parse arg opt, spec
o = catOpt(opt, 1)
if pos('£', o) > 0 then
return spec
else if pos('#', o) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, '£', '#'), envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', o) > 0 then
return catDsn('&'spec)
else
return catDsn(spec)
call err 'catMake implement' opt
if defDsn == '' then do
o = left(o, length(o)-1)
end
else if defDsn == '' then do
rw = catDsn(spec)
end
else do
rw = jReset(defDsn, spec)
end
if pos('-', o) < 1 then
call jOpen rw, o
return rw
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat')
m.m.catIx = -9
call catReset m
do ax=1 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catToClose = ''
m.m.catIx = -9
call oSetTypePara m
do ax=2 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
end
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx = mInc(m'.RWS.0')
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
if m.m.catIx >= 0 then do
if m.m.catRd ^== '' then do
ix = m.m.catIx
if pos('-', m.m.opts.ix) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
do wx = 1 to words(m.m.catToClose)
cl = word(m.m.catToClose, wx)
if cl ^== m then
call jClose cl
end
m.m.catToClose = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
call jClose m
if oo = 'r' then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if oo == 'w' | oo == 'a' then do
if oo == 'w' then
m.m.RWs.0 = 0
m.m.catIx = -7
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 & pos('-', m.m.opts.cx) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
oo = overlay('r', m.m.opts.cx)
if pos('-', oo) < 1 then
call jOpen m.m.RWs.cx, oo
return m.m.RWs.cx
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd ^== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then do
m.m.catWr = jOpen(jBuf(), 'w')
call oSetTypePara m.m.catWr, oGetTypePara(m)
end
call jWrite m.m.catWr, line
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)',' arg(3)') but opened,',
'catIx='m.m.catIx
bx = m.m.RWs.0
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx=bx+1
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
do ax=2 by 2 to arg()
bx=bx+1
m.m.opts.bx = catOpt(arg(ax))
m.m.RWs.bx = catMake(arg(ax), arg(ax+1))
call oSetTypePara m, oGetTypePara(m.m.RWs.bx)
end
m.m.RWs.0 = bx
return
endProcedure catWriteAll
/*--- store the list toClose to close them when closing cat ----------*/
catLazyClose: procedure expose m.
parse arg m, toClose
if m.m.catIx <> -7 then
call err 'catLazyClose with catIx' m.m.catIx
if m.m.RWs.0 = 0 then
return 0
if m.m.catToClose ^== '' then
call err 'catLazyClose with catToClose' m.m.catToClose
if m.m.catIx <> -7 | m.m.catToClose ^== '' then
m.m.catToClose = toClose
return 1
endProcedure catLazyClose
catSetTypePara: procedure expose m.
parse arg m, type
do ix=1 to m.m.RWs.0
call oSetTypePara m.m.RWs.ix, type
end
return
endProcedure catSetTypePara
/*--- create a reader/writer for a dsn -------------------------------*/
catDsn: procedure expose m.
parse arg spec
m = oNew('CatDsn')
m.m.readIx = 'c'
ix = mInc('CAT.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'CAT.BUF'ix
call catDsnReset m, spec
return m
endProcedure catDsn
catDsnReset: procedure expose m.
parse arg m, sp
if symbol('m.m.defDD') ^== 'VAR' then
m.m.defDD = 'CDD' mInc('CAT.DEFDD')
m.m.spec = sp
return m
endProcedure catDsnReset
catDsnOpen: procedure expose m.
parse arg m, opt
call jClose m
buf = m.m.buf
if opt == 'r' then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == 'w' then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else
call err 'catDsnOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure catDsnOpen
catDsnClose:
parse arg m
buf = m.m.buf
if m.m.readIx ^== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure catDsnClose
catDsnRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if ^ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure catDsnRead
catDsnWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure catDsnWrite
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
m.cat.buf = 0
call jIni
call oDecMethods oNewClass("Cat", "JRW"),
, "jOpen return catOpen(m, arg)",
, "jReset return catReset(m, '', arg)",
, "jClose call catClose m",
, "jWriteAll call err 'jWriteAll not opened w",
, "oSetTypePara call catSetTypePara m, type",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteAll call catWriteAll m, opt, rdr; return"
call oDecMethods oNewClass("CatDsn", "JRW"),
, "jOpen return catDsnOpen(m, arg)",
, "jReset return catDsnReset(m, arg)",
, "jClose call catDsnClose m",
, "jRead return catDsnRead(m, var)",
, "jWrite call catDsnWrite m, line"
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
if m.m.jReading then
interpret oObjMethod(m, 'jRead')
else
call err 'jRead('m',' var') but not opened r'
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
if m.m.jWriting then
interpret oObjMethod(m, 'jWrite')
else
call err 'jWrite('m',' line') but not opened w'
return
endProcedure jWrite
jWriteAll: procedure expose m.
parse arg m, opt, rdr
interpret oObjMethod(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteAllImpl: procedure expose m.
parse arg m, opt, rdr
if pos('-', opt) < 1 then
call jOpen rdr, catOpt(opt)
do while jRead(rdr, line)
call jWrite m, m.line
end
if pos('-', opt) < 1 then
call jClose rdr
return
endProcedure jWriteAll
jReset: procedure expose m.
parse arg m, arg
call jClose m
interpret oObjMethod(m, 'jReset')
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret oObjMethod(m, 'jOpen')
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
if m.m.jReading = 1 | m.m.jWriting = 1 then
interpret oObjMethod(m, 'jClose')
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
call oIni
call oDecMethods oNewClass("JRW"),
, "jRead call err 'jRead('m',' var') but not opened r'",
, "jWrite call err 'jWrite('m',' line') but not opened w'",
, "jWriteAll call jWriteAllImpl m, opt, rdr",
, "jRead drop m.arg; return 0",
, "jWrite say 'jOut:' line",
, "jReset ;",
, "jOpen ;",
, "jClose ;"
x = oNew("JRW")
m.j.jIn = x
m.x.jReading = 1
m.x.jWriting = 0
x = oNew("JRW")
m.j.jOut = x
m.x.jReading = 0
m.x.jWriting = 1
call oDecMethods oNewClass("Jbuf", "JRW"),
, "jOpen return jBufOpen(m, arg)",
, "jReset return jBufReset(m, arg)",
, "oSetTypePara call jBufSetTypePara m, type",
, "jRead return jBufRead(m, var)",
, "jWrite call jBufWrite m, line"
return
endProcedure jInit
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('Jbuf')
call jBufReset m
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
m.m.buf.0 = 0
call oSetTypePara m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
m.m.buf.0 = ax
end
return m
endProcedure jBufReset
jBufSetTypePara: procedure expose m.
parse arg m, type
if m.m.buf.0 <> 0 then
call err 'jBufSetTypePara but not empty'
return
endProcedure jBufSetTypePara
jBufOpen: procedure expose m.
parse arg m, opt
call jClose m
if opt == 'r' then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == 'w' then
m.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.var = m.m.buf.nx
else
call oTyCopy ty, var, m'.BUF.'nx
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
nx = mInc(m'.BUF.0')
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.m.buf.nx = line
else
call oTyCopy ty, m'.BUF.'nx, line
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy o begin ********************************************************
object layer has three freatures
* an object may have a class which has methods
* an object may have a parmeterized type
* a class may contain field descriptions
***********************************************************************/
oClaMethod: procedure expose m.
parse arg cl, me
if symbol('m.o.cla.cl.met.me') = 'VAR' then
return m.o.cla.cl.met.me
else
call err 'no method' me 'in class' cl
endProcedure oClaMethod
oHasMethod: procedure expose m.
parse arg obj, me
cla = oGetClass(obj)
return symbol('m.o.cla.cl.met.me') = 'VAR'
endProcedure oHasMethod
oGetClass: procedure expose m.
parse arg Obj
if symbol('m.o.obj2cla.Obj') = 'VAR' then
return m.o.obj2cla.Obj
call err 'no class found for object' obj
endProcedure oGetClass
oObjMethod: procedure expose m.
parse arg obj, me
if symbol('m.o.obj2cla.obj') = 'VAR' then
return oClaMethod(m.o.obj2cla.obj, me)
if abbrev(obj, 'oCast:') then do
cx = pos(':', obj, 7)
return 'M="'substr(obj, cx+1)'";' ,
oClaMethod(substr(obj, 7,cx-7), me)
end
call err 'no class found for object' obj
endProcedure oObjMethod
oCast: procedure
parse arg obj, cl
if abbrev(obj, 'oCast:') then
obj = substr(obj, 1 + pos(':', obj, 7))
return 'oCast:'cl':'obj
endProcedure oCast
oNewClass: procedure expose m.
parse arg name, super
/* call oIni */
name = oFldNew(name)
neMe = 'O.CLA.'name'.MET'
neFi = 'O.CLA.'name'.FLD'
do sx=1 to words(super)
sup = word(super, sx)
if symbol('m.o.cla.sup') ^== 'VAR' then
call err 'superclass' sup 'is not defined'
if m.o.cla.sup.val ^== '' then
m.o.cla.name.val = m.o.cla.sup.val
if m.o.cla.sup.stem ^== '' then
m.o.cla.name.stem = m.o.cla.sup.stem
st = 'O.CLA.'sup'.MET'
do x=1 to m.st.0
olMe = m.st.x
call oPut neMe, olMe, m.st.olMe
end
st = 'O.CLA.'sup'.FLD'
do x=1 to m.st.0
olFi = m.st.x
call oPut neFi, olFi, m.st.olFi
end
end
call oMutate 'O.CLA.'name, 'Class'
return name
endProcedure oNewClass
oValStemFldsWKOLD: procedure expose m.
parse arg cl, m.o.cla.cl.val, m.o.cla.cl.stem, flds
st = 'O.CLA.'cl'.FLD'
do wx=1 by 2 to words(flds)
call oPut st, word(flds, wx), word(flds, wx+1)
end
return cl
endProcedure oValStemFlds
oNewTypeWKOLD: procedure expose m.
parse arg cl, va, st, flds
return oValStemFlds(oNewClass(cl), va, st, flds)
/*--- a field type has only fields of type '='
finds or creates a field Type with the fields of types tps
and the field list aFl.
if dup = 'e' duplicate field names are resolved ------------*/
oFiTypeWKOLD: procedure expose m.
parse arg tps, aFl, dup
if symbol('m.o.cla.fiType.tps.aFl.dup') = 'VAR' then
return m.o.cla.fiType.tps.aFl.dup
fs = ''
do wx=1 to words(tps)
t1 = oFlds(word(tps, wx))
do fx=1 to m.t1.0
fs = fs m.t1.fx
end
end
fs = fs aFl
fd = ''
do wx=1 to words(fs)
f1 = word(fs, wx)
if wordPos(f1, fd) < 1 then do
fd = fd f1
end
else if dup == 'e' then do
do dx=2 by 1 while wordPos(f1 || dx, fn fs) > 0
end
fd = fd f1 || dx
end
end
fd = space(fd aFl)
if symbol('m.o.cla.fiType.fd') = 'VAR' then do
res = m.o.cla.fiType.fd
end
else do
res = oNewClass("FiType*")
m.o.cla.fiType.fd = res
st = 'O.CLA.'res'.FLD'
do wx=1 to words(fd)
call oPut st, word(fd, wx), '='
end
end
m.o.cla.fiType.tps.aFl = res
return res
endProcedure oFiType
oDecMethods: procedure expose m.
parse arg cla
st = 'O.CLA.'cla'.MET'
do ax=2 to arg()
call oPut st, word(arg(ax), 1), subWord(arg(ax), 2)
end
return
endProcedure oDecMethods
oNew: procedure expose m.
parse arg cla
st = 'O.CLA.'cla
if symbol('M.st') ^== 'VAR' then
call err 'class' cla 'is not initialized'
nn = m.st.inst + 1
m.st.inst = nn
nn = 'O.C' || m.st || 'I' || nn
if symbol('m.o.obj2cla.nn') == 'VAR' then
call err 'oNew already defined:' nn
m.o.obj2cla.nn = cla
return nn
endProcedure oNew
oMutate: procedure expose m.
parse arg obj, class
if obj == 'O.C13I12' then do
end
if symbol('M.O.CLA.class') ^== 'VAR' then
call err 'class' class 'is not initialized'
m.o.obj2cla.obj = class
return obj
endProcedure oMutate
oSay: procedure expose m.
parse arg type, a, aPr, mPr
ty = 'O.CLA.'type
msg = mPr || substr(a, length(aPr)+1)
redir = 0
do forever
if type == '=' then do
say msg '=' m.a
return
end
else if abbrev(type, '=') then do
a = m.a
msg = msg '==>' a
redir = 1
type = substr(type, 2)
end
else if left(type, 2) = '<>' then do
k = m.a
a = left(a, lastPos('.', a))k
msg = msg '=<>' k
redir = 1
type = substr(type, 3)
end
else if left(type, 1) = '.' then do
if ^ datatype(m.a.0, 'n') then
call err 'type' type 'not stem but m.'a'.0 is' m.a.0
type = substr(type, 2)
if redir then do
say msg 'stem 1..'m.a.0':' type
end
else do
do y=1 to m.a.0
call oSay type, a'.'y, a'.', mPr' '
end
end
return
end
else if redir then do
say msg':' type
return
end
else do
leave
end
end
if m.ty.val = '=' then
say msg '=' m.a
else
say msg '=' m.a':' m.ty.val
/* call oSay m.ty.val, a,==>' m.a '(to' m.ty.val')' */
do y=1 to m.ty.fld.0
f = m.ty.fld.y
call oSay m.ty.fld.f , a'.'f, a'.', mPr' '
end
if m.ty.stem ^== '' then
call oSay '.'m.ty.stem, a, a, mPr
return
endProcedure oSay
oClear: procedure expose m.
parse arg type, a, val
if abbrev(type, '.') then do
m.a.0 = 0
end
else if abbrev(type, '<>') then do
m.a = val
call oClear substr(type, 3), left(a, lastPos('.', a))val, val
end
else if abbrev(type, '=') then do
m.a = ''
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.a = val
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oClear m.ty.fld.k, a'.'k, val
end
if m.ty.stem ^== '' then
call m.a.0 = 0
end
return a
endProcedure oClear
oCopy: procedure expose m.
parse arg t, f
if symbol('m.o.obj2cla.f') ^== 'VAR' then
call err f 'has no class'
cl = m.o.obj2cla.f
m.o.obj2cla.t = m.o.obj2cla.f
return oTyCopy(cl, t, f)
endProcedure oCopy
oTyCopy: procedure expose m.
parse arg type, t, f
if abbrev(type, '.') then do
do y=1 to m.f.0
call oTyCopy substr(type, 2), t'.'y, f'.'y
end
m.t.0 = m.f.0
end
else if abbrev(type, '<>') then do
k = m.f
m.t = k
call oTyCopy substr(type, 3), left(t, lastPos('.', t))k,
, left(f, lastPos('.', f))k
end
else if abbrev(type, '=') then do
m.t = m.f
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.t = m.f
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oTyCopy m.ty.fld.k, t'.'k, f'.'k
end
if m.ty.stem ^== '' then
call oTyCopy '.'m.ty.stem, t, f
end
return t
endProcedure oTyCopy
/*--- Run ------------------------------------------------------------*/
oRunner: procedure expose m.
parse arg code
return oRunnerReset(oNew('ORunner'), code)
oRunnerReset: procedure expose m.
parse arg m, pCode
m.m.code = pCode
return m
endProcedure oRunnerReset
oRun: procedure expose m.
parse arg m
interpret m.m.code
return
endProcedure oRun
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call oFldIni
call mapIni
m.o.paTy.0 = 0
call oFldNew '=', '='
call oDecMethods oNewClass('ORunner'), 'oRun call oRun m'
return
endProcedure oIni
/* copy o end *********************************************************/
/* copy oFld begin *****************************************************
defines classes with field names
is the base for the oo layer in copy o
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
oFldIni: procedure expose m.
if m.oFld.ini = 1 then
return
m.oFld.ini = 1
call mapIni
m.o.fldOnly = mapNew() /* map fields -> class */
m.o.cla.0 = 0 /* the stem for classes */
call oFldNew 'Class', '=', , , /* MetaClass definieren */
'INST = MET .<>= FLD .<>=Class STEM =Class'
return
endProcedure oFldIni
/*--- create a new class
name: name of new class, a star will be replaced by a number
va: type of value
st: type of stem
flds: pairs of field names and types
dup: duplicate resolver -----------------------------------*/
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
/*--- create or find a class with only simple fields fs --------------*/
oFldOnly: procedure expose m.
parse arg fs, dup
kk = space(fs '?'dup, 1)
if mapHasKey(m.o.fldOnly, kk) then
return mapGet(m.o.fldOnly, kk)
if dup ^== 'e' then do
ll = space(fs, 1)
end
else do
ll = ''
do wx=1 to words(fs)
w = word(fs, wx)
v = w
do x=2 while wordPos(v, ff) > 0
v = w || x
end
ll = space(ll v, 1)
end
end
if mapHasKey(m.o.fldOnly, ll) then do
nn = mapGet(m.o.fldOnly, ll)
end
else do
nn = oFldNew('FldType*')
st = 'O.CLA.'nn'.FLD'
do lx=1 to words(ll)
call oPut st, word(ll, lx), '=', dup
end
call mapPut m.o.fldOnly, ll, nn
end
call mapPut m.o.fldOnly, kk, nn
return nn
endProcedure oFldOnly
/*--- return the stem of flds of class type --------------------------*/
oFlds: procedure expose m.
parse arg type
return 'O.CLA.'type'.FLD'
/*--- return the concatenation of the fields of type ty in stem st
formated by fmt -------------------------------------------*/
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
/*--- add fields to class cl given as name type pairs in fs ----------*/
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
/*--- add/put key k with value v to stem st
duplicate handling dup:
* replace * in k by a number until it is new
e add a number in it is not new
o replace old value at existing key
= add a new key, fail if key exists and value is different
------------------------------------------------------------*/
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' k
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
/* copy oFld end ***************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = ''
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
if abbrev(a, 'MAP.') then do
do kx=1 to m.map.loKy.a.0
drop m.map.loKy.a.kx m.map.loVa.a.kx
end
m.map.loKy.a.0 = 0
end
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
if mapValAdr(a, ky) ^== '' then
call err 'duplicate key in mAdd('a',' ky',' val')'
if length(ky) < 200 then do
m.a.ky = val
end
else do
kx = mInc('MAP.LOKY.'a'.0')
m.map.loKy.a.kx = ky
m.map.loVa.a.kx = val
end
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky)
if vv ^== '' then
m.vv = val
else
call mapAdd a, ky, val
return val
endProcedure mapPut
/*--- return the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg a, ky
if length(ky) < 200 then do
if symbol('m.a.ky') == 'VAR' then
return a'.'ky
end
else if ^ abbrev(a, 'MAP.') then do
call err 'key too long mapValAdr('a',' ky')'
end
else do
do kx=1 to m.map.loKy.a.0
if m.map.loKy.a.kx == ky then
return 'MAP.LOVA.'a'.'kx
end
end
return ''
endProcedure mapValAdr
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if abbrev(vv, 'MAP.LOVA.') then
call err 'not implemented mapRemove('a',' ky')'
drop m.a.ky
return val
endProcedure mapRemove
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a,
fail if it does not exist ----------------------------------*/
mapGet: procedure expose m.
parse arg a, ky, noKey
vv = mapValAdr(a, ky)
if vv == '' then
call err 'missing key in mapGet('a',' ky')'
return m.vv
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- 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 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 readDDBegin grp
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 readDDEnd 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 jOut 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 jOut 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 *************************************************/
/* 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 expose m.
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 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 ''
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 expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- 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, disp, dd, retRc
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))
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
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
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use -"dd
if dd = '' then do
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 pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(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)'
interpret subword(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
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso 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 that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '\n'
say addition message in stem st ---------------------------*/
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 expose m.
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 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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
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 *****************************************************/