zOs/war/rexx0
}¢--- A540769.WK.REXX(#JINFO) cre=2014-04-15 mod=2014-04-15-12.12.20 A540769 ---
/* rexx */
call #jInfo_jobInfo
say 'job' #jInfo_jName 'num' #jInfo_jNum 'step' #jInfo_jProcStep
exit
/*
** >>Jobinfo
*/
#JINFO_JOBINFO:
#JINFO@cvt = storage(10,4) /* FLCCVT-PSA data area */
#JINFO@cvtsname = storage(d2x(c2d(#JINFO@cvt) + 340),8) /* CVTSNAME */
#JINFO@tcbp = storage(d2x(c2d(#JINFO@cvt)),4) /* CVTTCBP */
#JINFO@tcb = storage(d2x(c2d(#JINFO@tcbp)+4),4)
#JINFO@tiot = STORAGE(D2X(C2D(#JINFO@tcb)+12),4) /* Get TIOT address */
#JINFO@jscb = STORAGE(D2X(C2D(#JINFO@tcb)+180),4)
#JINFO@ssib = STORAGE(D2X(C2D(#JINFO@jscb)+316),4)
#JINFO@jinfo = STORAGE(D2X(C2D(#JINFO@tiot)),24)
#JINFO_JTYPE = STORAGE(D2X(C2D(#JINFO@ssib)+12),3)
#JINFO_JNUM = strip(storage(D2X(C2D(#JINFO@ssib)+15),5),l,0)
#JINFO_JNAME = substr(#JINFO@jinfo,1,8)
#JINFO_JPROC = substr(#JINFO@jinfo,9,8)
#JINFO_JPROCSTEP = substr(#JINFO@jinfo,17,8)
#JINFO_CVTSNAME = #JINFO@cvtsname /* system name */
drop #JINFO@cvt #JINFO@tcbp #JINFO@tcb #JINFO@tiot #JINFO@jscb
drop #JINFO@ssib #JINFO@jinfo #JINFO@cvtsname
return
#JINFO_DROP:
DROP #JINFO_JTYPE #JINFO_JNUM #JINFO_JNAME #JINFO_JPROC #JINFO_JPROCSTEP
return
}¢--- A540769.WK.REXX(@) cre=2013-08-07 mod=2015-03-16-12.17.53 A540769 --------
$#:
abc = xyz * k1 ?
* kommentar ?
$@ say 'abc='$abc
proc $@/eins/ say 'eins abc='$abc $/eins/
$@ say 'call eins'
@eins
$#end
say '@' symbol('@') @
@ = 'v=@'
say '@' symbol('@') @
say 'abc@efg' symbol('abc@efg') abc@efg
abc@efg = 'v=abc@efg'
say 'abc@efg' symbol('abc@efg') abc@efg
say '@123' symbol('@123') @123
@123 = 'v=@123'
say '@123' symbol('@123') @123
say '@abc@123@' symbol('@abc@123@') @abc@123@
@abc@123@ = 'v=@abc@123@'
say '@abc@123@' symbol('@abc@123@') @abc@123@
say 1@ 1a 'but are no variables |'
if 0 then
1@=1a
drop @ abc@efg @123 @abc@123@
say 'm.@' symbol('m.@') m.@
m.@ = 'v=m.@'
say 'm.@' symbol('m.@') m.@
say 'm.abc@efg' symbol('m.abc@efg') m.abc@efg
m.abc@efg = 'v=m.abc@efg'
say 'm.abc@efg' symbol('m.abc@efg') m.abc@efg
say 'm.@123' symbol('m.@123') m.@123
m.@123 = 'v=m.@123'
say 'm.@123' symbol('m.@123') m.@123
say 'm.@abc.@123@' symbol('m.@abc@123@') m.@abc@123@
m.@abc@123@ = 'v=m.@abc@123@'
say 'm.@abc@123@' symbol('m.@abc@123@') m.@abc@123@
a = vPut()
$#out 20150316 11:43:08
$#out 20150316 11:39:59
$#out 20150316 11:39:37
$#out
}¢--- A540769.WK.REXX(@1) cre=2013-08-08 mod=2016-10-03-21.02.23 A540769 -------
$$ out eins
}¢--- A540769.WK.REXX(A) cre=2016-03-01 mod=2016-03-01-17.00.17 A540769 --------
select '
}¢--- A540769.WK.REXX(ABUB) cre=2014-01-13 mod=2016-10-05-11.54.44 A540769 -----
/* rexx ***************************************************************
abUb: Ablauf Ueberwachung version 1.0
synopsis: abub fun opts? 9. 9.16
fun:
c: check alle Ablauefe auf allen rz/dbSys und eventTable updaten
opts list of words
all: alle Abläufe auch wenn nach Kalender nicht nötig
ab=tecSv nur Ablauf tecSv
rz=rzy nur rzy
--- history -----------------------------------------------------------
8. 8.16 walter: neue timestamps ab 1.9.16, neue copies
*********/ /*** end of help *******************************************
1. 2.16 walter: cpuGr in controlSummary eingebaut
4. 1.16 walter: var $cx, fix tst for new ablauf
23.10.15 walter: support supervisor job QZT1100P
no tLib for send mail, it's allocated in jcl
19.10.15 walter: intRdr jes2: append space for 80 chars
11. 6.15 walter: html mails und new view
27. 4.15 walter: tecSvConSummarySummary in tecSv und als batch
20. 2.15 walter: loadCols für gbGr v11 und fixe für RZ0
3.10.14 walter: strip ab, neue Vars AB ablfN rzD, @ statt bei no db
29.09.14 walter: timeout during logon ==> disconnected
25.09.14 walter: ii mit RQ2
26.06.14 walter: controlSummary auch fuer GbGr
17.05.14 walter: nowM: mit MicroSekunden, new wsh version
29.05.14 walter: loopCheck in abubRun
15.05.14 walter: if ; then ; else
8.05.14 walter: cosmetics/fix
16.04.14 walter: function dir
16.04.14 walter: resOr initialisiert bei Fortsetzung
2.04.14 walter: dirDT fuer mvExt eingebaut
1.04.14 walter: vars ablfP und ablfS, skip tst% ablaeufe
31.03.14 walter: fix insert connect
24.03.14 walter: dsl mit ioRedirection
18.03.14 walter: hlq=QZ
12.01.14 walter: neu
**********************************************************************/
parse arg aFun aArgs
upper aFun
call wshIni
call errReset 'h'
m.my.job = mvsvar('symdef', 'jobname')
m.my.isTest = \ abbrev(m.my.job, 'QZT11')
m.my.abPred = "ab not like 'tst%'"
m.my.mailId = 'db-administration.db2@credit-suisse.com'
m.my.resTst = f('%t s')
m.timeLimit = 900
m.mail_libAdd = m.my.isTest
if 0 then do
say 'abub is currently not active'
exit 0
end
if m.my.isTest then do
m.my.mailId = 'walter.keller@credit-suisse.com'
if 0 then
m.my.abPred = "rz = 'RZX'"
else if 0 then
m.my.abPred = "ab like 'tec%' and rz = 'RZX'"
else if 0 then
m.my.abPred = "ab like 'tst%'"
m.timeLimit = 1
if aFun <> '' then
nop
else if 1 then
aFun = '?T'
else if 0 then
parse value 'TECSVCONSUM dsn.abub.tecsv.rzx' ,
'DSN.ABUB.TECSV.CONSUMSU' ,
with aFun aArgs
else if 0 then
parse value 'C ALL rz=RZX ab=tecSv' with aFun aArgs
else if 0 then
parse value 'C' with aFun aArgs
else if 0 then
parse value 'C ALL' with aFun aArgs
end
say 'abub version 1.0 vom 9. 9.16 at' time() date('s'),
'tst='m.my.isTest 'mailId='m.my.mailid
m.csm_timeout = 20
m.my.dbSy = dp4g
m.my.ab = 'abub'
m.my.rz = sysvar(sysnode)
m.my.staTst = f('%t s')
m.ruleTb = oa1p.tQZ046AbUbRule
m.eventTb = oa1p.tQZ045AbUbEvent
m.checkVw = oa1p.vQZ045AbUbStat3
m.skels = dsn.abub.a.skels
if m.my.staTst < '2016-09' then do /* old dsn timestamp formats */
m.fMbrM = '%tsA' /* A8himnst member name for month */
m.fMbrY = '%tsM' /* M78himns member name for year */
m.fPreS = '%tsZ.@%tsH' /* dsn Prefix with secs */
m.fPreM = '%(%tsZ%,%-2C%).D@%(%tsd%,%-4C%)' /* month lib */
m.fPreY = '%(%tsZ%,%-1C%).D@%(%tsd%,%-2C%)' /* year lib */
end
else do /* new dsn timestamp formats */
m.fMbrM = '%tsY' /* YM78Imqr member name for month */
m.fMbrY = '%tsY' /* YM78Imqr member name for year */
m.fPreS = '%tsY' /* dsn Prefix with secs */
m.fPreM = 'D@%(%tsd%,%-4C%)' /* month lib */
m.fPreY = 'D@%(%tsd%,%-2C%)' /* year lib */
end
if aFun == 'C' then
call check aArgs
else if aFun == 'TECSVCONSUM' then
call controlSummaryBatch aArgs
else if aFun == '?T' then do
call sqlConnect m.my.dbSy
call checkLastEnd
call checkEndMail 1
call sqlDisconnect
end
else
call err "bad fun '"aFun"'"
exit 0
/*--- check alle Abläufe in allen rz/subsys -------------------------*/
check: procedure expose m.
parse arg opts
call sqlConnect m.my.dbSy
call checkLastEnd
oAll = "and (cuEvent is null or cuEvent like '>%' or cont <> ''" ,
" or cuTst < cuStart )"
oAb = ''
m.dslMany = 0
m.all = 0
do ox=1 to words(opts)
o1 = word(opts, ox)
oU = translate(o1)
if oU = 'ALL' then do
oAll = ''
m.all = 1
end
else if abbrev(oU, 'AB=') then
oAb = oAb "and ab = '"substr(o1, 4)"'"
else if abbrev(oU, 'DB=') then
oAb = oAb "and dbSy = '"substr(o1, 4)"'"
else if abbrev(oU, 'RZ=') then
oAb = oAb "and rz = '"substr(oU, 4)"'"
else if abbrev(oU, 'DSLMANY') then
m.dslMany = 100
else
call err 'bad opt' o1 'in opts' opts
end
call sql2St "select c.* from" m.checkVw "c" ,
"where type = 'ab' and" m.my.abPred oAb oAll, ca
call parmLoad
call sqlCommit
call checkWork 1
call err 'never pass here, because of recovery procedure'
endProcedure check
checkWork: procedure expose m.
parse arg startX
say 'checkWork elapsed' time('e') 'at' time()
if startX == 1 then do
m.ca.noCon = ''
m.ca.inUse = 0
m.ca.otErr = 0
m.dsl.mask = ''
end
m.ca.lastIx = 0
call errReset 'h', 'call checkErrHandler ggTxt'
do cx=startX to m.ca.0
m.ca.curIx = cx
cy = 'CA.'cx
upper m.cy.rz
if m.cy.cuTst == m.sqlNull then
m.cy.cuTst = '1111-11-11-11.11.11'
if m.cy.orTst == m.sqlNull then
m.cy.orTst = '1111-11-11-11.11.11'
m.cy.resOr = m.my.staTst
say left('checking' m.cy.ab 'in' m.cy.rz'/'m.cy.dbSy ,
m.cy.cuEvent m.cy.cuTst, 78, '-')
if m.cy.cuEvent \== m.sqlNull ,
& abbrev(m.cy.cuEvent, '>') \== (m.cy.cont <> '') then
call err 'cuEvent' m.cy.cuEvent 'mismatches cont' m.cy.cont
else if m.cy.cuEvent==m.sqlNull | m.cy.cuTst < m.cy.cuStart ,
| m.cy.cont = '' ,
| (m.all & timestampDiff(m.my.resTst,
, m.cy.cuTst) > 0.13) then do
code = 'inc' m.cy.ab
m.cy.resEv = ''
m.cy.cuLink = ''
end
else do
code = m.cy.cont
m.cy.resEv = substr(m.cy.cuEvent, 2)
m.cy.resOr = m.cy.orTst
end
if m.cy.done == 1 then
say ' already done'
else if wordPos(m.cy.rz, m.ca.noCon) > 0 then
say ' rz not connected, skipping'
else do
res = abubRun(cy, code)
/* say '??? run res' res 'resTst' m.cy.resTst 'cuTst' m.cy.cuTst */
if m.cy.cuTst = m.cy.resTst then
say ' checkResult ==>' m.cy.resEv 'cuLink:' m.cy.cuLink
else
say ' checkResult ==> nothing detected'
m.cy.done = 1
end
end
call errReset 'h' /* switch off errHandler */
if m.ca.noCon \== '' | m.ca.inUse \== 0 | m.ca.otErr \== 0 then do
say 'noConnectionTo='m.ca.noCon', inuse='m.ca.inuse ,
|| ', otherErrors='m.ca.otErr
if time('e') > m.timeLimit/3 then do
say 'no retry, because of timeLimit' m.timeLimit
end
else do
call sqlCommit
call sleep trunc(1+m.timeLimit/3)
say 'retrying checkwork' m.timeLimit
call checkWork 1
call err 'never pass here'
end
end
call checkEnd
call sqlDisconnect
exit 0
endProcedure checkWork
checkErrHandler: procedure expose m.
parse arg t1 t2 tR
call errReset 'h' /* switch off errHandler */
call errCleanup
cy = 'CA.'m.ca.curIx
rz = m.cy.rz
if t1 == 'csmExec' & t2 == 'noConn' then do
/* pos(':'rz' ', tR) > 0 ??? can also be System |||| */
m.ca.noCon = m.ca.noCon rz
say 'errHandler: no connect to rz' rz':' t1 t2 tR
end
else if t1 == 'csmExec' & t2 == 'inUse' then do
m.ca.inUse = m.ca.inUse + 1
say 'errHandler: file inuse:' t1 t2 tR
end
else do
m.ca.otErr = m.ca.otErr + 1
say 'errHandler: other error:' t1 t2 tR
end
say 'checkErrHandler continuing with next checkWork'
call checkWork m.ca.curIx + 1
call err 'never pass here'
endProcedure checkErrHandler
/*--- one action ----------------------------------------------------*/
abubRun: procedure expose m.
parse arg cx, code
m.cx.resTsM = f('%t S')
m.cx.resTst = f('%tSs', m.cx.resTsM)
if m.cx.cuTst = m.cx.resTst then
call err 'resTst = cuTst' m.cx.cuTst
call vPut 'cx', cx
call vPut 'ab', strip(m.cx.ab)
call vPut 'AB', translate(strip(m.cx.ab))
call vPut 'rz', m.cx.rz
if m.cx.dbsy = '' then
m.cx.dbsy = '*'
call vPut 'dbSys', strip(m.cx.dbSy)
call vPut 'rzC', iiRz2c(m.cx.rz)
call vPut 'rzD', iiRz2Dsn(m.cx.rz)
if m.cx.dbsy = '*' then
d1 = '@'
else
d1 = iiDBSys2c(m.cx.dbSy)
call vPut 'j2', iiRz2c(m.cx.rz)d1
call vPut 'jP', iiRz2p(m.cx.rz)d1
call vPut 'abVa3', if(m.cx.va3='', m.sqlNull, strip(m.cx.va3))
call vPut 'abVa4', if(m.cx.va4='', m.sqlNull, strip(m.cx.va4))
call vPut 'calVa4', if(m.cx.calVa4='', m.sqlNull,strip(m.cx.calVa4))
call vPut 'now', m.cx.resTst
call vPut 'nowM', m.cx.resTsM
call vPut 'ablfN', 'DSN.ABLF.'vGet('AB')
call vPut 'ablfP', ablfPref(cx)
call vPut 'ablfS', ablfPref(cx, 's')
call vPut 'abubP', abubPref(cx)
vars = 'ab AB rz dbSys rzC rzD j2 abVa3 abVa4 now nowM' ,
'ablfN ablfP ablfS abubP'
var0 = length(vars) + 1
p0 = m.pipe.0
pIn = ''
pOut = ''
do rx=1
zero = cutStmtFromCode()
if zero = '' then do
if m.pipe.0 \== p0 then
call err fun 'end in pipe: pipe.0='m.pipe.0 'p0='p0
call eventCommit cx, '', substr(vars, var0)
return 1
end
/* say '???zero' zero 'code' code */
one = abubExpand(zero, vars)
/* say '???one ' one 'code' code */
if rx > 1000 then do
say 'abubRun Loop' rx':' one
if rx > 1100 then
call err 'abubRun Loop' rx':' one
end
else if 0 then
say '???abubRun' rx':' one
sx = wordindex(one, 2)
if sx > 0 then
sx = verify(left(one, sx), '#=?', 'm')
else
sx = verify(one, '#=?', 'm')
if sx > 0 then do
v1 = strip(left(one, sx-1))
fun = substr(one, sx, 1)
rest = strip(substr(one, sx+1))
end
else do
parse var one fun rest
end
if \ (p0 = m.pipe.0 ,
| (p0 + 1 = m.pipe.0 & pIn == '' & pOut == '')) then
call err 'pipe.0='m.pipe.0 'p0='p0' 'pIn='pIn' 'pOut='pOut,
'one='one 'code='code
if pos(left(fun, 1), '<>') > 0 then do /* pipe */
if p0 <> m.pipe.0 then
call pipe '-'
if one == '<>' then
parse value with '' pIn pOut
else if substr(one, 2) = '' then
call err 'bad pipe' one';' code
else if abbrev(fun, '<') then
pIn = strip(substr(one, 2))
else
pOut = strip(substr(one, 2))
iterate
end
else if pIn \== '' | pOut \== '' then do
/* say '???run pipe >'pOut '<'pIn */
f = '+ '
if pOut \== '' then do
pOut = file(pOut)
f = overlay('F',f , 2)
end
if pIn \== '' then do
pIn = file(pIn)
f = overlay('f',f, 3)
end
call pipe f, pOut, pIn
pOut = ''
pIn = ''
end
if wordPos(fun, '? commit wait') > 0 then do /* return */
if m.pipe.0 \== p0 then
call err fun 'in pipe: pipe.0='m.pipe.0 'p0='p0 ,
one';'code
if fun == '?' then do
val = abubOne(cx, word(rest, 1), subWord(rest, 2))
if val = '' | val = 0 then
return 0
vars = abubPut(vars, v1, val)
end
else do
call eventCommit cx, code, substr(vars, var0)
if fun = 'wait' then
return 0
end
end
else if fun == '#' then do
vars = abubPut(vars, v1, rest)
end
else if fun == '=' then do
vars = abubPut(vars, v1, abubOne(cx, word(rest, 1),
, subWord(rest, 2)))
end
else if fun = 'inc' then do
parse var rest inc rest
if rest <> '' then
call err 'implement inc args for:' one
px = parmGet(inc, 'code')
code = strip(m.px.va3)';' strip(m.px.va4)';' code
end
else if fun = 'if' then do
ifTrue = rest <> '' & rest <> 0
ifThen = cutStmtFromCode()
if word(ifThen, 1) = 'then' then
ifElse = cutStmtFromCode()
else do
ifElse = ifThen
ifThen = ''
end
if word(ifElse, 1) <> 'else' then do
code = ifElse';' code
ifElse = ''
if ifThen = '' then
call err 'if without then or else' rest';'code
end
if ifTrue then
code = substr(ifThen, 6)';'code
else
code = substr(ifElse, 6)';'code
end
else do
call abubOne cx, fun, rest
end
end
endProcedure abubRun
cutStmtFromCode: procedure expose m. code
/* say '???ruC' code */
sx = verify(code, ' ;', 'n')
if sx=0 then do
code = ''
return ''
end
sy = pos(';', code, sx)
if sy = 0 then do
res = substr(code, sx)
code = ''
end
else do
res = substr(code, sx, sy-sx)
code = substr(code, sy+1)
end
/*say '???stmt' strip(res) ';code' code */
return strip(res)
endProcedure cutStmtFromCode
abubPut: procedure expose m.
parse arg vars, v1, val
v1 = strip(v1)
call vPut v1, strip(val)
if wordPos(v1, vars) > 0 then
return vars
else
return vars v1
endProcedure abubPut
abubOne: procedure expose m.
parse arg cx, fun, args
/* say '???one' fun args */
if fun = 'conSum' then
return controlSummary(cx, args)
else if fun = 'dirDel' then
return checkDirDel(cx, args)
else if fun = 'dir' then
return dsList(args)
else if fun = 'dirOne' then
return dirOne(word(args, 1), subWord(args, 2))
else if fun = 'libMbr' | fun = 'abubMbr' then
return abubMbr(cx, args)
else if fun = 'libPref' | fun = 'ablfPre' then
return ablfPref(cx, args)
else if fun = 'dirDT' then
return dirDT(cx, args)
/* else if fun = 'loadCols' then ???? direkt aus skeleton qzt31L
return loadCols() */
else if fun = 'skel' then
return runMbr(args)
else
call err 'abubOne implement:' fun'('args')'
endProcedure abubOne
abubExpand: procedure expose m.
parse arg src, vars
res = ''
sx = 1
do forever
sy = pos('$', src, sx)
if sy = 0 then
return res || substr(src, sx)
sz = verify(src, m.ut_alfId, 'n', sy+1)
if sz < 1 then
sz = length(src)+1
v = substr(src, sy+1, sz-sy-1)
if wordPos(v, vars) < 0 then
call err 'bad var' v 'in' src
res = res || substr(src, sx, sy-sx) || vGet(v)
sx = sz
end
endProcedure mapExpand
/*--- dirRead: check directory, read one dsn -------------------------*/
checkDirRead: procedure expose m.
parse arg cx, dir one stm xtra
call assert "xtra = ''"
dsn = dirOne(dir, one)
if dsn == '' then
return 0
call readDsn dsn, 'M.'stm'.'
return 1
endProcedure checkDirRead
/*--- dirDel: delete all files in directory -------------------------*/
checkDirDel: procedure expose m.
parse arg cx, dir
if dsList(dir) = 0 then
say ' 0 dsns deleted in' dir
parse var m.dsl.mask rz '/' mask
do dx=1 to m.dsl.0
dsn = m.dsl.dx
say ' ' dx 'deleting' rz'/'dsn
call csmDel rz, dsn
end
return 1
endProcedure checkDsnDel
/*--- send a mail, if last good end of abub
was more than 130 minutes ago ------------------------------*/
checkLastEnd: procedure expose m.
r =sql2One("select case when tst < current timestamp -130 minutes",
"then 1 else 0 end, e.*" ,
"from" m.eventTb e ,
"where ab = 'abub'",
"order by tst desc fetch first 1 row only", abub,,, 22)
say 'last good end of abub' if(r=2, 'never', m.abub.tst)
if r = 0 then
return
say 'mail for abub timeout'
call myMailHead qq, 'AbUb: timeout in der Ablaufüberwachung'
m.my.resTst = m.my.staTst
call mailText qq, '<h1>letztes normales Ende von AbUb' ,
if(r=2, 'noch nie', 'um' m.abub.tst ,
'vor mehr als 2 Stunden') '</h1>' ,
, '<ul><li>job' mvsvar('symdef', 'jobname') ,
'im' sysvar(sysnode)'</li>' ,
, '<li>um' m.my.resTst '</li></ul>'
call mailSend qq, abubMbr(my, 'm errHtml :v2000')
return
endProcedure checkLastEnd
/*--- insert a event, to show a normal end of abub -------------------*/
checkEnd: procedure expose m.
m.nc.ab = 'connect'
m.nc.dbSy = '*'
m.nc.resTst = f('%t s')
m.my.resTst = m.nc.resTst
/* check all connections
insert an event iff connection status changed */
do cx=1 to m.ca.0
aRz = m.ca.cx.rz
if done.aRz == 1 then
iterate
done.aRz = 1
if wordPos(aRz, m.ca.noCon) > 0 then
rr = 'err'
else
rr = 'ok'
m.nc.rz = aRz
fRes = sql2One("select * from" m.eventTb ,
"where ab = 'connect' and rz ='"aRz"'" ,
"and dbSy = '*'",
"order by tst desc fetch first 1 row only",
, fRz, , , '--')
if fRes == '-' | m.fRz.event <> rr then do
m.nc.resEv = rr
m.nc.cuTst = 'insert'
m.nc.resOr = if(fRes == '-',m.my.staTst, m.fRz.tst)
m.nc.cuLink = ''
call eventCommit nc
end
end
call sqlCommit
abubLi = checkEndMail(0)
say 'normalEnd at' m.my.resTst
m.my.resEv = 'ok'
m.my.cuTst = 'insert'
m.my.resOr = m.my.staTst
m.my.cuLink = left('EOJ:' abubLi, 60)
call eventCommit my
return
endProcedure checkEnd
checkEndMail: procedure expose m.
parse arg force
/* check current alarms */
call sql2St 'select * from' m.checkVw ,
"where" m.my.abPred, ca
cNew = 0 /* count new states */
cNPr = 0 /* count prod changes (without new) */
eZ = 0 /* event list */
firstErr = ''
do cx=1 to m.ca.0
cy = ca'.'cx
e = strip(m.cy.status)
if symbol('e.e') \== 'VAR' then do
eZ = eZ + 1
eL.eZ = e
e.e = 0
n.e = 0
end
e.e = e.e + 1
if m.cy.alarm = 'new' then do
n.e = n.e + 1
if e <> 'ok' then do
cNew = cNew + (e <> 'prod')
if e = 'sox' & abbrev(firstErr, 'sox') then
firstErr = firstErr e m.cy.rz'/'m.cy.dbSy
else if e = 'sox' | firstErr = '' ,
| (e <> 'prod' & \ abbrev(firstErr, 'prod')) then
firstErr = e m.cy.rz'/'m.cy.dbSy
end
end
end
doMail = 1
if firstErr = '' then do
firstErr = 'no news'
doMail = force
end
else if abbrev(firstErr, 'prod') then
firstErr = 'info' subWord(firstErr, 2)
sub = 'AbUb:' space(firstErr, 1) 'at' m.my.resTst
ln = ''
lt = ''
do ex=1 to eZ
e = eL.ex
lt = lt',' e.e e
if n.e \== 0 then
ln = ln',' n.e e
end
if ln <> '' then
res = sub 'new:' substr(ln, 3)
else
res = sub 'total:' substr(lt, 3)
if \ doMail then do
say 'schlussendlich no mail:' res
return 'no mail:' res
end
say 'schlussendlich mail:' res
mailText = abubMbr(my, 'm allText :v2000')
mailErr = abubMbr(my, 'm errHtml :v2000')
mailAll = abubMbr(my, 'm allHtml :v2000')
/* generate all text */
m.dt.0 = 0
tFmt = fGen('%>' , '@RZ%-3C @DBSY%-4C @AB%-8C' ,
'@ALARM%-4C @STATUS%-8C @TIMEOUT%-8C' ,
'@CUEVENT%-8C @CUTST%-19C @CULINK%-60C' ,
'@CSEVENT%-8C @CSTST%-19C @CSLINK%-60C' ,
'@NXSTART%-19C' ,
'@PREVENT%-8C @PRTST%-19C @PRLINK%-60C' ,
'@CONEV%-8C @CONTST%-19C @CONPRI%-4C @ABUBTST%-19C' ,
'@CT%-2C @CUTIOUSECS%7i @NXSTART%-19C' ,
'@CUSTART%-19C @PRSTART%-19C' )
hEv = left('event', 8)
hTst = left('timestamp', 19)
hLi = left('link or info', 60)
hPrCy = 'previous finished cycle'
call mAdd dt, sub,
, ' AblaufUeberwachungs Mail von' m.my.resTst ,
, ' text all stati' ,
, ' err html' word(mailErr, 1) ,
, ' all html' word(mailAll, 1) ,
, ' all text' word(mailText, 1) ,
, ' job' mvsvar('symdef', 'jobname'),
'from' sysvar(sysnode), ' ' , ' ' ,
, left('', 17) left('current cycle ', 112, '.') ,
left('newest controlSummary', 89, '.') ,
left('', 19) left(hPrCy, 89, '.') ,
left('connection ', 33, '.') 'previous Abub Run ' ,
left('calendar ', 70, '.') ,
, 'rz dbSy Ablauf new? seve timeout ' ,
hEv hTst hLi hEv hTst hLi left('nextStart', 19) ,
hEv hTst hLi hEv hTst 'status ' hTst ,
'ct timeout' left('next start', 19) ,
left('current start', 19) left('previous start', 19)
do cx=1 to m.ca.0
call mAdd dt, f(tFmt, ca'.'cx)
end
call writeDsn mailText, 'M.DT.'
/* generate err and all html */
refMvsB = "<a hRef='https://web-pd-sec.csintra.net/MVSDS/%27"
refMvsM = "%27'>"
refMvsE = "</a>"
sNew = "style='background-color: blue; color: white;" ,
"font-weight: bold;'"
sErr = "style='background-color: yellow;'"
sSox = "style='background-color: red;'"
m.da.0 = 0
m.de.0 = 0
call mAdd de, '<h1>' sub '</h1>' ,
, '<ul>' ,
, '<li>AblaufUeberwachung Mail von' m.my.resTst'</li>' ,
, '<li>new events:' substr(ln, 3)'</li>' ,
, '<li>all stati:' substr(lt, 3)'</li>' ,
, '</ul>'
call mAddSt da, de
call mAdd de, '<h3>only errors and prodInfos</h3>'
call mAdd da, '<h3>all stati</h3>'
t1 = "<table border='1' style='font-size: smaller;'>"
t2 = "<tr style='font-size: larger;'><th colspan='3'></th>"
t3 = "current cycle</th><th>newest</th>" ,
"<th colspan='3'>" hPrCy "</th>"
t4 = "<tr style='font-size: larger;'>" ,
"<th>rz</th><th>dbSys</th><th>ablauf</th>" ,
"<th>new?</th>"
t5 = "<th>timeout</th>" ,
"<th>event</th><th>"hTst"</th><th>"hLi"</th>" ,
"<th>controlSummary</th>" ,
"<th>event</th><th>"hTst"</th><th>"hLi"</th>"
call mAdd de, t1, t2 "<th colspan='5'>" t3"</tr>", t4 t5 "</tr>"
call mAdd da, t1, t2 "<th colspan='6'>" t3 ,
"<th colspan='5'>calendar</th></tr>" ,
, t4 "<th>status</th>" t5,
'<th>ct</th><th>timeout</th><th>next start</th>' ,
'<th>current start</th><th>previous start</th></tr>'
/* generate formats */
eF = '<tr> <th>@2%S</th><th>@3%S</th> <td>@1.AB%S</td>',
'<td @4%S>@1.ALARM%S</td>'
aF = eF '<td>@1.STATUS%S</td>'
cL = '<td @CUSTY%C>'
pL = '<td @PRSTY%C>'
r1 = cL'@TIMEOUT%S</td>' ,
cL'@CUEVENT%S</td>' cL'@CUTST%S</td>' cL'@CULILI%S</td>' ,
'<td @CSSTY%C>@CSLILI%S</td>',
pL'@PREVENT%S</td>' PL'@PRTST%S</td>' pL'@PRLILI%S</td>'
eF = eF r1 '</tr>'
aF = aF r1 '<td>@CT%C</td><td>@CUTIOUSECS%C</td>',
'<td>@NXSTART%C</td><td>@CUSTART%C</td>' ,
'<td>@PRSTART%C</td></tr>'
eFmt =fGen('%>', eF)
aFmt =fGen('%>', aF)
/* format each line */
do cx=1 to m.ca.0
cy = ca'.'cx
if m.cy.cuEvent = 'sox' then
m.cy.cuSty = sSox
else if m.cy.timeout <> '' ,
| wordPos('?'m.cy.cuEvent, '? ?ok ?> ?>ok ?>err') < 1 then
m.cy.cuSty = sErr
else
m.cy.cuSty = ""
m.cy.cuLiLi = htmlMvsLink(m.cy.cuLink)
m.cy.csLiLi = htmlMvsLink(m.cy.csLink, m.cy.csEvent m.cy.csTst)
if m.cy.csEvent = 'sox' then
m.cy.csSty = sSox
else if wordPos('?'m.cy.csEvent, '? ?ok ?> ?>ok ?>err' )<1 then
m.cy.csSty = sErr
else
m.cy.csSty = ''
if m.cy.prEvent = 'sox' then
m.cy.prSty = sSox
else if wordPos('?'m.cy.prEvent , '?ok ?'m.sqlNull ) < 1 then
m.cy.prSty = sErr
else
m.cy.prSty = ""
m.cy.prLiLi = htmlMvsLink(m.cy.prLink, , 20)
call mAdd da, f(aFmt, cy, copies(m.cy.rz, aRz <> m.cy.rz) ,
, copies(m.cy.dbSy, m.cy.rz m.cy.dbSy <> aRz aDb) ,
, copies(sNew, m.cy.alarm = 'new'))
aRz = m.cy.rz
aDb = m.cy.dbSy
if m.cy.status <> 'ok' & m.cy.alarm <> 'old' then do
call mAdd de, f(eFmt, cy, copies(m.cy.rz, eRz <> m.cy.rz) ,
, copies(m.cy.dbSy, m.cy.rz m.cy.dbSy <> eRz eDb),
, copies(sNew, m.cy.alarm = 'new'))
eRz = m.cy.rz
eDb = m.cy.dbSy
end
end
/* add trailer */
t2 = '<ul><li>err html' word(mailErr, 1)'</li>' ,
'<li>all html' word(mailAll, 1)'</li>' ,
'<li>'refMvsB || word(mailText, 1) || refMvsM,
'text:' word(mailText, 1) refMvsE '</li>' ,
'<li> job' mvsvar('symdef', 'jobname'),
'from' sysvar(sysnode)'</li>' ,
"<li>colors: <span" sNew">new</span>, " ,
"<span" sErr">error</span> and" ,
"<span" sSox">violation of SOX policy</span></li> ",
'</ul>'
call mAdd de, "</table>", t2
call writeDsn mailErr, 'M.DE.'
call mAdd da, "</table>", t2
call writeDsn mailAll, 'M.DA.'
call myMailHead qq, sub
call mAdd qq, 'att=DSN¢'word(mailAll, 1)'!FILE¢all.html!',
, 'textDsn='word(mailErr, 1)
call mailSend qq
return 'mail:' res
endProcedure checkEndMail
htmlMvsLink: procedure expose m.
parse arg t r, sh, cut
if t = m.sqlNull then
return ''
if \ abbrev(t, 'DSN.ABUB.') then
if cut \== '' & length(t r) > cut then
return left(t r, cut)
else
return t r
if sh == '' then
sh = substr(t, lastPos('.', t))
return "<a hRef='https://web-pd-sec.csintra.net/MVSDS/%27" ,
|| t"%27'>" sh "</a>"
endProcedure htmlMvsLink
htmlEsc: procedure expose m.
parse arg src
return repall(src, '<', '<', '>', '>')
/*--- check dsnDel with parm px and status cx ------------------????
checkDsnDel: procedure expose m.
parse arg px, cx
rz = m.cx.rz
say ' checkDsnDel parm' m.px.type m.px.subType 'va3' m.px.va3
dl = dsList(cx, m.px.va3)
say ' ' m.dl.0 'dsns last' m.dl.lastX
call sqlUpdPrep 7, 'insert into' m.eventTb 'values(?,?,?,?,?,?,?)'
do dx=1 to m.dl.0
say ' ' dx m.dl.dx m.dl.dx.llq m.dl.dx.tst
ev = if(m.dl.dx.llq = 'OK' | \ m.dl.ok, 'ok', 'err')
if sqlUpdArgs("7 -803", m.cx.ab, rz, m.cx.dbSy,
,m.cx.resTst, ev, m.dl.dx.tst, m.dl.dx) = -803 then
say " duplicate on insert" m.cx.ab 'in' rz"/"m.cx.dbSy,
m.dl.dx.tst ev m.dl.dx.llq m.dl.dx
end
call sqlCommit
do dx=1 to m.dl.0
dsn = m.dl.dx
say ' ' dx 'deleting' rz'/'dsn
call csmDel rz, dsn
end
return 'ok'
endProcedure checkDsnDel */
/*--- check tecSv with controlSummary -----------------------------?????
checkTecSv: procedure expose m.
parse arg px, cx
rz = m.cx.rz
dbSy = m.cx.dbSy
say ' checkTecSv parm' m.px.type m.px.subType,
'va3' m.px.va3 'va4' m.cx.va4
if abbrev(m.cx.event, '>') then
return copyDelRecover(cx, word(m.cx.va4, 1))
say ' check dsList' word(m.cx.va4, 1)
dl = dsList(cx, word(m.cx.va4, 1))
ox = -1
do dx=1 to m.dl.0
if m.dl.dx.ll2 \== 'DSNTEP2.OUT' then
iterate
else if ox > 0 then
call err 'duplicate dsnTep2.out' m.dl.dx
ox = dx
end
say ' dsnTep2.out' ox m.dl.ox
if ox < 1 then
return 0
return controlSummaryIO(cx, dl, ox,
, abubMonLib(cx, contSUm, ':F133'))
endProcedure checkTecSv ?????? */
controlSummary: procedure expose m.
parse arg cx, var dbLoc .
ib = in2Buf()
i = ib'.BUF'
say ' controlSummary' m.i.0 'sqlOuts, variant' var
if var == 'tecSv' then
ti = 'Control Summary'
else if var == 'ddlCon' then
ti = 'DDL Control'
else if var == 'gbGr' then
ti = 'GigaByte Grenze'
else if var == 'cpuGr' then
ti = 'cpu Grenze'
else
call err 'controlSummary bad ab' var
m.o.0 = 0
m.e.0 = 0
call mAdd o, overlay(left(m.cx.rz'/'m.cx.dbSy, 20) ,
ti, right(m.cx.resTst, 70), 1), '', ''
/* search identifikation */
do ix=1 to min(40, m.i.0-2) ,
while wordPos('CURRENTSERVER', translate(m.i.ix)) = 0
end
tx = wordpos('CURRENTSERVER',translate(m.i.ix))
ty = wordpos('NOW', translate(m.i.ix))
hasId = tx > 1 & ty > 1
t2 = ''
m.cx.idTst = ''
t1 = ''
if \ hasId then do
if var \== 'gbGr' then
t1 = 'no identification found'
end
else do
tx = wordIndex(m.i.ix, tx-1)
ty = wordIndex(m.i.ix, ty-1)
ix = ix+2
cuSe = word(substr(m.i.ix, tx+1), 1)
t1 = 'currentserver' cuSe
if dbLoc \== m.sqlNull then
if dbLoc = cuSe then
t1 = t1 'match'
else
t1 = t1 'in sql <>' word(m.cx.va4, 2) 'in rule'
else if right(cuSe, 4) = m.cx.dbSy then
t1 = t1 'match dbSy'
else
t1 = t1 'in sql' cuSe '<>' m.cx.dbSy 'in rule'
now = word(substr(m.i.ix, ty+1), 1)
t2 = 'timestamp in sql' now
if translate(now, 000000000, 123456789) ,
= '0000-00-00-00.00.00.000000' then
m.cx.resOr = now
else do
say 'bad now timestamp in' m.i.ix
t2 = t2 'bad timestamp'
end
end
c.s = 0
ce.s = 0
c.r = 0
ce.r = 0
c.oth = 0
ce.oth = 0
cOk = 0
cWa = 0
cEr = 0
tx = 0
do ix=1 to m.i.0
if lastPos('--$$', m.i.ix, 8) > 0 then do
if tx \== 0 then
call mAdd e, 'no result found for' tx':' m.i.tx
tx = ix
end
else if lastPos('SUCCESSFUL RETRIEVAL OF', m.i.ix, 30) ,
> 0 then do
cOk = cOk + 1
rest = substr(m.i.ix,
, 23+lastPos('SUCCESSFUL RETRIEVAL OF', m.i.ix, 30))
if word(rest, 2) \== 'ROW(S)' then
call mAdd e, '||| row(s) not found in' ix':' m.i.oy
cnt = word(rest, 1)
if \ dataType(cnt, 'n') then
call mAdd e, '||| rows not numeric in' ix':' m.i.oy
else if tx \== 0 then do
ti = substr(m.i.tx, lastPos('--$$', m.i.tx, 8)+4)
ty = translate(left(ti, 1))
if var = 'tecSv' & symbol('c.ty') == 'VAR' then
ti = strip(substr(ti, 2))
else do
ty = 'OTH'
ti = strip(ti)
end
c.ty = c.ty + 1
ce.ty = ce.ty + cnt
call mAdd o, overlay(cnt, ti, 71-length(cnt))
tx = 0
end
end
else if pos('SQLCODE =', m.i.ix) > 0 then do
cd = word(substr(m.i.ix, pos('SQLCODE =', m.i.ix)+9), 1)
if pos(',', cd) > 0 then
cd = left(cd, pos(',', cd) - 1)
if cd = 0 then
cOk = cOk + 1
else if datatype(cd, 'n') & cd > 0 then
cWa = cWa + 1
else do
cEr = cEr + 1
call mAdd e,'|||' substr(m.i.ix,pos('SQLCODE =',m.i.ix))
end
end
end
if m.cx.rz == 'RZ2' & wordPos(m.cx.dbSy, 'DBOF DVBP') > 0 then do
sox = 'SOX'
s3 = sox
end
else do
sox = 'Recoverability/sx'
s3 = 'Rec/sx'
end
call mAdd o, '', (cOk+cWa+cEr) 'sqls,' cOk 'ok,' cWa 'warnings,' ,
cEr 'errors'
if var == 'tecSv' then
call mAdd o, ce.s 'errors in' c.s sox 'reports',
, ce.r 'errors in' c.r 'Recoverability reports',
, ce.oth 'errors in' c.oth 'other reports'
else if var = 'ddlCon' then
call mAdd o, ce.oth 'errors in' c.oth 'DDL reports'
else
call mAdd o, ce.oth 'Limiten überschritten'
if t1 \== '' then
call mAdd o, t1, t2, ''
do ex=1 to m.e.0
call mAdd o, left(m.e.ex, 130)
end
call mAdd o, '', left('', 130, '.'), ''
ti = ''
eAb = 0
do ox=1 to m.o.0
eAb = eAb + abbrev(m.o.ox, '|')
end
eAb = max(eAb, cEr)
if eAb > 0 then
ti = ti',' eAb 'abUb'
if ce.s <> 0 then
ti = ti',' ce.s s3
if ce.r <> 0 then
ti = ti',' ce.r 'Rec'
if ce.oth = 0 then
nop
else if var = 'ddlCon' then
ti = ti',' ce.oth 'ddlControl'
else if var = 'gbGr' then
ti = ti',' ce.oth 'Schwellen überschritten'
else
ti = ti',' ce.oth 'Other'
if ti \== '' then do
if var \== 'gbGr' then
ti = ti 'errors'
m.o.2 = overlay('' substr(ti, 3)' ', left('',70,'*'),21)
end
else do
if var == 'gbGr' then
ti = 'alle Schwellen OK'
else
ti = 'ok - no errors in' (c.s + c.r + c.oth) 'reports'
m.o.2 = left('', 20) ti
end
call outSt o
call outSt i
m.cx.resEv = if(m.e.0 + ce.s + ce.r + ce.oth = 0, 'ok', 'err')
if var == 'tecSv' then do
tOut = mGet(m.j.out'.DSN')
tLib = left(tOut, pos('TECSV.', tOut)+5) ,
|| 'CONSUMSU('vGet('jP')substr(m.cx.resTst, 3, 2)')'
call controlSummarySum o, m.cx.rz'/'m.cx.dbSy, tLib ,
, tOut, m.o.0 + m.i.0
if sox = 'SOX' & ce.s > 0 then
m.cx.resEv = 'sox'
end
m.cx.cuLink = mGet(m.j.out'.DSN')
return 1
endProcedure controlSummary
/*--- add the current controlSummary to the summarySummary ----------*/-
controlSummarySum: procedure expose m.
parse arg o, rzDb, suSuDsn, sumDsn . , sumLines
res = controlSummarySumLine(o, sumDsn, sumLines)
if rzDb <> word(res, 1) then
call err 'controlSummarySum rzDb='rzDb 'mismatches res='res
call controlSummarySumOpen suSuDsn, rzDb, 0
call controlSummarySumAdd res
call controlSummarySumClose
/* delete empty members */
cnt = 0
do mx=mbrList(mbl, dsnSetMbr(sumDsn)) by -1 to 1 while cnt <= 2
dsn = dsnSetMbr(sumDsn, m.mbl.mx)
if dsn = sumDsn then
iterate
call readDsn dsn, ii.
if ii.0 == 0 then do
call adrTso "delete '"dsn"'"
say mx dsn ii.0 'deleted empty member'
end
else do
cnt = cnt + 1
say mx dsn ii.0
end
end
return
endProcedure controlSummarySum
/*--- extract a summary line from a conSum in a stem ---------------*/
controlSummarySumLine: procedure expose m.
parse arg ii, sumDsn, sumLines
if subword(m.ii.1, 2, 2) <> 'Control Summary' then
call err 'bad line' sumDsn'.1:' m.ii.1
res = word(m.ii.1, 1) word(m.ii.1, 4)
do y = 5 to min(25, m.ii.0) ,
while word(m.ii.y, 2) <> 'sqls,'
end
if word(m.ii.y, 2) <> 'sqls,' ,
| word(m.ii.y, 8) <> 'errors' then
call err 'bad sqls line' sumDsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'SOX' ,
& word(m.ii.y, 5) <> 'Recoverability/sx' then
call err 'bad SOX line' sumDsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'Recoverability' then
call err 'bad Recoverability line' sumDsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'other' then
call err 'bad other line' sumDsn'.'y':' m.ii.y
return res left(strip(m.ii.y), 49) sumDsn sumLines 'lines'
endProcedure controlSummarySumLine
/*--- open a controlSummarySummary ----------------------------------*/
controlSummarySumOpen: procedure expose m.
parse arg dsn, rzDb, reUse
if reUse then do
if dsn <> m.susu_dsn | rzDb <> m.susu_rzDb then
call err 'open reuse mismatch'
do while controlSummarySumOutNx()
end
m.susu.0 = 0
call mAddSt susu, susuOut
end
else if dsnExists(dsn) then
call readDsn dsn, m.suSu.
else
m.suSu.0 = 0
m.susu_dsn = dsn
m.susu_rzDb = rzDb
call controlSummarySumInNx 1
noteMbr = 'NOTE'right(dsnGetMbr(m.suSu_Dsn), 2)
m.susu_noteSt = 'SUSU.'noteMbr
m.suSuOut.0 = 0
if symbol('m.susu.noteMbr.0') \== 'VAR' then do
noteDsn = dsnSetMbr(m.suSu_Dsn, noteMbr)
if dsnExists(noteDsn) then
call readDsn noteDsn, 'M.SUSU.'noteMbr'.'
else
m.susu.noteMbr.0 = 0
end
return controlSummarySumNoteNx(1)
endProcedure controlSummarySumOpen
/*--- finish and write a summary summary ----------------------------*/
controlSummarySumClose: procedure expose m.
do while controlSummarySumOutNx()
end
call writeDsn m.susu_dsn, 'M.SUSUOUT.', , 1
return
endProcedure controlSummarySumClose
/*--- add a line to a summary summary in desc tst sequence ----------*/
controlSummarySumAdd: procedure expose m.
parse arg resLine
parse var resLine w1 w2 .
if m.susu.0 > 0 & w1 <> m.susu_rzdb then
call 'rzDb <>' m.susu_rzdb '\nadd' resLine
noteSt = m.susu_noteSt
do forever
if m.susuOut.0 > 0 then do
ox = m.susuOut.0
if w2 >> word(m.susuOut.ox, 2) then
call err 'add' resLine '\nnewer out' ox':' m.susuOut.ox
else if w2 = word(m.susuOut.ox, 2) ,
& translate(word(m.susuOut.ox, 3)) <> 'NOTE' ,
& resLine <> m.susuOut.ox then
call err 'add' resLine '\ntime o<>' ox':' m.susuOut.ox
end
noteNx = m.susu_nx
ix = m.susu_ix
if noteNx > m.noteSt.0 | w2 >> word(m.noteSt.noteNx, 2) then do
if ix > m.susu.0 | w2 >> word(m.susu.ix, 2) then
return mAdd(susuOut, resLine)
if w2 = word(m.susu.ix, 2) then do
if resLine = m.susu.ix then
return
call err 'add' resLine '\ntime i<>' ix':' m.susu.ix
end
end
if \ controlSummarySumOutNx() then
call err 'forever'
end
endProcedure controlSummarySumAdd
/*--- update/create controlSummarySummary for dsn Mask --------------*/
controlSummaryBatch: procedure expose m.
parse upper arg dsnMsk libOut
if libOut = '' then
libOut = 'DSN.ABUB.TECSV.CONSUMSU'
say 'tecSvConSum ==> controlSummaryBatch'
say 'mask' dsnMsk '==> libOut' libOut
if dsnMsk = '' then
call err 'mask is empty'
call csiOpen dsl, dsnMsk
susuOld = ''
do while csiNext(dsl, dsl)
parse value substr(m.dsl, 15, 18) ,
with '.' rz '.' dbSys '.' . '.' dt '.'
if dt << 'D1404' then do
say 'too old, skipping' m.dsl
iterate
end
susuNew = libOut'('iirz2P(rz)iidbSys2c(dbSys)substr(dt, 2, 2)')'
if susuOld <> susuNew & susuOld <> '' then
call controlSummarySumClose
call controlSummarySumOpen susuNew, rz'/'dbSys, susuOld=susuNew
susuOld = susuNew
do mx=mbrList(mbl, m.dsl) by -1 to 1
dsn = m.dsl'('m.mbl.mx')'
call readDsn dsn, m.ii.
if m.ii.0 = 0 then do
call adrTso "delete '"dsn"'"
say mx dsn m.ii.0 'deleted because empty' dsn
end
else do
say mx dsn m.ii.0
res = controlSummarySumLine(ii, dsn, m.ii.0)
call controlSummarySumAdd res
end
end
end
if susuOld <> '' then
call controlSummarySumClose
return
endProcedure controlSummaryBatch
controlSummarySumNoteNx: procedure expose m.
parse arg sx
noteSt = m.susu_noteSt
do nx=sx to m.noteSt.0 while translate(word(m.noteSt.nx, 1)) ,
<> m.susu_rzDb
end
if nx <= m.noteSt.0 then
if translate(word(m.notest.nx, 3)) <> 'NOTE' then
call err 'word(3) <> NOTE in' noteSt nx':'m.noteSt.nx
m.susu_nx = nx
return nx
endProcedure controlSummarySumNoteNx
controlSummarySumOutNx: procedure expose m.
noteSt = m.susu_noteSt
nx = m.susu_nx
ix = m.susu_ix
if ix <= m.susu.0 & ( nx > m.noteSt.0 ,
| word(m.susu.ix, 2) >> word(m.noteSt.nx,2 )) then do
if word(m.susu.ix, 1) \== m.susu_rzDb then
call err 'rzDB <>' m.susu_rzDb 'in' ix':' m.susu.ix
call mAdd susuOut, m.susu.ix
call controlSummarySumInNx ix+1
return 1
end
else if nx <= m.noteSt.0 then do
if translate(word(m.noteSt.nx, 1)) \== m.susu_rzDb then
call err 'rzDB <>' m.susu_rzDb ,
'in note' nx':' m.noteSt.nx
call mAdd susuOut, m.noteSt.nx
call controlSummarySumNoteNx nx+1
return 1
end
else
return 0
endProcedure controlSummarySumOutNx
controlSummarySumInNx: procedure expose m.
parse arg nx
do ix=nx to m.susu.0 while translate(word(m.susu.ix, 3)) == 'NOTE'
end
m.susu_ix = ix
return
endProcedure controlSummarySumInNx
dirDT: procedure expose m.
parse arg cx, dir mf opts
if opts = '' then
opts = 'elo'
res = dsListDT(dir)
parse var res cDs cTst be en
if cDs == 0 then
return 0
if mf == '' | mf = '-' then
mf = 5
li = ''
if cTst < 1 then
li = 'no tst dsn'
else if be <= m.cx.orTst then
li = 'tst <= last'
else if cDs <> cTst then
li = 'dsn without tst'
else if cTst > mf then do
say cTst m.dsl.0 'dsns in' dir 'more than' mf
if m.dslMany > 0 then
m.dsl.0 = min(cTst, m.dslMany)
else
li = 'many dsn'
end
if pos('e', opts) > 0 then
m.cx.resEv = word('ok err', 1 + (li \== ''))
if pos('l', opts) > 0 then
m.cx.cuLink = strip(li res)
if pos('o', opts) > 0 & cTst > 0 then
m.cx.resOr = en
return res
endProcedure dirDT
/*???????????????????
copyDelRecover: procedure expose m.
parse arg cx, dir .
say ' copyDelRecover dir' dir
dl = dsList(cx, dir)
say ' ' m.dl.0 'dsns'
oDsn = abubDsn(cx, 'DUMP', ':F')
oPre = left(oDsn, lastPos('.', oDsn)-1)
do dx=1 to m.dl.0
ri = substr(m.dl.dx, length(dir) + 2)
if length(oPre ri) > 44 then
ri = 'DUMP'right(dx, 4, 0)
o.dx = right(dx, 4) left(ri, 20)m.dl.dx
end
call writeDsn oDsn, o., m.dl.0, 1
rz = m.cx.rz
do dx=1 to m.dl.0
call csmCopy rz'/'m.dl.dx, oPre'.'word(o.dx, 2)
call csmDel rz, m.dl.dx
end
call eventCommit?? cx, substr(m.cx.event, 2), m.cx.evtst, m.cx.link
return substr(m.cx.event, 2)
endProcedure copyDelRecover
/*--- check list -----------------------------------------------------*/
checkList: procedure expose m.
parse arg px, cx
rz = m.cx.rz
dbSy = m.cx.dbSy
say ' checkList parm' m.px.type m.px.subType 'va1='m.cx.va1
do yy=1
py = parmGet(m.px.va1, 'rParm'yy, '')
if py == '' then
leave
end
if m.cx.step == '' then do
m.cx.stepLast = yy-1
sx = 1
end
else if m.cx.stepLast \== yy-1 then
call err 'stepLast' m.cx.stepLast 'mismatches' (yy-1)
else do
sx = m.cx.step + 1
end
if sx < 1 | sx > m.cx.stepLast
call err 'step' sx 'not in range'
res = ''
pz = parmGet(m.px.va1, 'rParm'sx, '')
do sx=sx while pz \== ''
py = pz
pz = parmGet(m.px.va1, 'rParm' || (sx+1), '')
evIx = copies(sx, pz \== '')
say ' listEntry' sx m.py.subType 'evIx' evIx '-------------'
res = checkOne(py, cx, evIx)
if res = 'wait' then
return res
else if wordPos(res, 'err ok') < 1 then
call err 'implement res='res 'for' m.py.subType
end
return res
endProcedure checkList
checkSubmit: procedure expose m.
parse arg cx, toRz mbr
call runMbr m.px.va1, cx, toRz'/intRdr'
return 0
endProcedure checkSubmit ???????????? */
runMbr: procedure expose m.
parse upper arg mbr
mbr = translate(strip(mbr))
if symbol('m.runMbr.mbr') \== 'VAR' then do
if sysDsn("'"m.skels"("mbr")'") \== 'OK' then
call err 'missing skel' m.skels'('mbr') ==>' ,
sysDsn("'"m.skels"("mbr")'")
m.runMbr.mbr = wshHookComp( , '=', file(m.skels"("mbr")"))
end
call oRun m.runMbr.mbr
return 1
endProcedure runMbr
eventCommit: procedure expose m.
parse arg cx, code, vars
/* Achtung, Felder erst nach sqlUpdate modifizieren,
wenn Programm einen DB2 Fehler ueberlebt
muss es mit den alten Werten wieder aufsetzen | */
m.cx.resEv = strip(translate(m.cx.resEv, ' ', '>'))
if code <> '' then do
vv = ''
do vx=1 to words(vars)
vv = vv || word(vars, vx)'#'vGet(word(vars, vx))';'
end
code = vv code
m.cx.resEv = '>'m.cx.resEv
end
else if m.cx.resEv = '' then
m.cx.resEv = 'ok'
if m.cx.cuTst \== m.cx.resTst then
call sqlUpdate 7, 'insert into' m.eventTb "values('"m.cx.ab"'",
", '"m.cx.rz"', '"m.cx.dbSy"', '"m.cx.resTst"'",
", '"m.cx.resEv"'" ,
", '"m.cx.resOr"', '"m.cx.cuLink"', '"code"')"
else
call sqlUpdate 7, "update" m.eventTb ,
"set event = '"m.cx.resEv"', orTst = '"m.cx.resOr"'",
", link = '"m.cx.cuLink"', cont = '"code"'" ,
"where ab ='"m.cx.ab"' and rz = '"m.cx.rz"'" ,
"and dbSy = '"m.cx.dbSy"' and tst = '"m.cx.resTst"'"
call sqlCommit
m.cx.cuEvent = m.cx.resEv
m.cx.cuTst = m.cx.resTst
m.cx.cont = code
return
endProcedure eventCommit
abubMbr: procedure expose m.
parse arg cx, ty llq recfm
if recfm = '' then
recfm = '::f133'
else
recfm = ':'recfm
recfm = recfm 'mgmtClas(COM#A091)'
res = abubPref(cx, ty)copies('.'llq, llq \== '')
if ty == 'm' then
return mbrChk(res'('f(m.fMbrM, m.cx.resTst)')') recfm
else if ty == 'y' then
return mbrChk(res'('f(m.fMbrY, m.cx.resTst)')') recfm
else
call err 'abubMbr bad ty' ty
endProcedure abubMbr
mbrChk: procedure expose m.
parse arg dsn
/* if the mbr already exists, change last char */
do cx=1 while sysDsn("'"dsn"'") = 'OK'
if cx > 26 then
call err 'all dsns already exist:' dsn
dsn = overlay(substr(m.ut_alfUC, cx, 1), dsn, length(dsn)-1)
end
return dsn
endProcedure mbrChk
abubDsn: procedure expose m.
parse arg cx, nm, recfm
return abubPref(cx, 's')'.'nm ':'recfm 'mgmtClas(COM#A091)'
endProcedure abubDsn
abubPref: procedure expose m.
parse arg cx, v
return abubPre2(cx, 'DSN.ABUB.'strip(m.cx.ab)'.'strip(m.cx.rz), v)
ablfPref: procedure expose m.
parse arg cx, v
return abubPre2(cx, 'DSN.ABLF.'strip(m.cx.ab), v)
abubPre2: procedure expose m.
parse arg cx, p , v
if m.cx.dbSy <> '' & m.cx.dbSy <> '*' then
p = p'.'strip(m.cx.dbSy)
upper p
if v = '' then /* prefix without time */
return p
else if v == 's' then /* inlcuding seconds */
return p'.'f(m.fPreS, m.cx.resTst)
else if v == 'm' then /* month library */
return p'.'f(m.fPreM, m.cx.resTst)
else if v == 'y' then /* year library */
return p'.'f(m.fPreY, m.cx.resTst)
else
call err 'bad abubPre2 v='v
endProcedure abubPre2
myMailHead: procedure expose m.
parse arg m, sub
return mailHead(m, sub, m.my.mailId, m.my.mailId)
dsList: procedure expose m.
parse arg aMsk
bMsk = dsnCsmSys(dsnSetMbr(aMsk), 1)
parse var bMsk sys '/' msk
if m.dsl.mask == bMsk then
return m.dsl.0
call adrCsm 'dslist system('sys') dsnMask('msk'.**) short', 4
m.dsl.0 = stemSize
m.dsl.mask = bMsk
do sx=1 to stemSize
m.dsl.sx = dsName.sx
end
return m.dsl.0
endProcedure dsList
dirOne: procedure expose m.
parse arg aMsk, one
if dsList(aMsk) < 1 then
return ''
parse var m.dsl.mask sys '/' msk
srch = msk || left('.', one <> '') || strip(one)
do sx = 1 to m.dsl.0
if m.dsl.sx == srch then
return sys'/'srch
end
return ''
endProcedure dirOne
dsListDT: procedure expose m.
parse arg aMsk
c = dsList(aMsk)
if c = 0 then
return c
cT = 0
do dx=1 to c
d1 = strip(m.dsl.dx)
l2 = right(d1, 15)
m.dsl.dx.tst = ''
if translate(l2, '000000000', '123456789') ,
<> '.D00000.T000000' then
iterate
t = translate('1234-56-78-9a.bc.de',
, date('s',substr(l2, 3, 5), 'j')substr(l2,10,6) ,
, '123456789abcde')
m.dsl.dx.tst = t
if cT == 0 | an > t then
an = t
if cT == 0 | en < t then
en = t
cT = cT + 1
end
if cT == 0 then
return c 0
else
return c cT an en
endProcedure dsListDT
/*--- load rPar% from rule table ------------------------------------*/
parmLoad: procedure expose m.
call sql2St 'select r.*, current timestamp now from' m.ruleTb 'r',
"where type like 'code%'", rPar
do rx=1 to m.rPar.0
ky = strip(m.rPar.rx.rule)'.'strip(m.rPar.rx.type)
m.rPar.ky = 'RPAR.'rx
end
return
endProcedure parmLoad
/*--- get the stem of a parameter -----------------------------------*/
parmGet: procedure expose m.
parse arg ab, pa
ab = strip(ab)
pa = strip(pa)
if symbol('m.rPar.ab.pa') == 'VAR' then
return m.rPar.ab.pa
if arg() > 2 then
return arg(3)
call err 'parmGet no parm' ab'.'pa'|'
endProcedure
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlIni
call fTabIni
call csmIni
return
endProcedure wshIni
/*--- call hooks and/or compile wsh
finally execute any generated code ----------------------------*/
wshRun: procedure expose m.
parse arg m, spec, inp
m.m.info = 'compile'
r = wshHookComp(m, spec, inp)
m.m.info = 'run'
if r \== '' then
call oRun r
return
endProcedure wshRun
/*--- call hooks, handle $# clauses, compile wsh
return generated code as ORunner or ''-------------------------*/
wshHookComp: procedure expose m.
parse arg m, spec, inp
if m == '' then do
if symbol('m.wsh_new') \== 'VAR' then
m.wsh_new = 1
else
m.wsh_new = m.wsh_new + 1
m = 'wsh_new'm.wsh_new
end
m.m.in = inp
m.m.comp = ''
m.m.kind = '@'
m.m.out = ''
m.m.wshEnd = 0
run = ''
rest = strip(spec)
if abbrev(rest, '$#') then
rest = strip(substr(rest, 3))
do until m.m.comp \== '' | rest = ''
if pos(left(rest, 1), '<>') > 0 then
parse var rest s2 r2
else
parse var rest s2 '$#' r2
run = run wshHook(m, strip(s2), rest)
rest = strip(r2)
end
if m.m.comp \== '' then do
c = m.m.comp
s = m.c.scan
do while \ m.m.wshEnd
if \ scanLit(s, '$#') then
leave
call scanChar s
sp2 = m.s.tok
run = run wshHook(m, sp2, sp2)
end
call compEnd c, left(m.m.kind, \ m.m.wshEnd)
end
run = space(run, 1)
if words(run) <= 1 then
return run
else
return oRunner('call oRun' repAll(run, ' ', '; call oRun '))
endProcedure wshHookComp
/*--- compile wsh until eof or unknown syntax -----------------------*/
wshHook: procedure expose m.
parse arg m, spec, specAll
parse var spec sp1 spR
if pos(left(sp1, 1), '<>') > 0 then
return wshHookRedir(m, sp1 spR)
if verifId(sp1) > 0 | sp1 == '' then
return wshCompile(m, specAll)
if wordPos(sp1, 'out end version') <= 0 then do
cd = "return wshHook_"sp1"(m, '"strip(spR)"')"
/* say 'interpreting hook' cd */
interpret cd
end
c = m.m.comp
s = m.c.scan
if c == '' then
call err 'wshHook before compiler created:' spec
else if sp1 == 'out' then do
m.m.out = scanPos(s)
m.m.wshEnd = 1
end
else if sp1 == 'end' then
call scanNlUntil s, '$#out'
else if m.s.tok == 'version' then
call scanErr s, 'implement version'
return ''
endProcedure wshHook
/*--- initialize compiler if necessary and compile one unit ---------*/
wshCompile: procedure expose m.
parse arg m, spec
spec = strip(spec, 'l')
if m.m.comp == '' then
call wshIni
if pos(left(spec, 1), m.comp_chKind'*') > 0 then
parse var spec m.m.kind 2 spec
if m.m.comp == '' then do
c = comp(m.m.in)
m.m.comp = c
call compBegin c, spec
end
else do
c = m.m.comp
call scanBack m.c.scan, spec
end
return compile(c, m.m.kind)
endProcedure wshCompile
/*--- redirection hook ----------------------------------------------*/
wshHookRedir: procedure expose m.
parse upper arg m, op 2 dsn
call pipeIni
f = ''
if op == '<' then
call pipe '+f', , file(dsn)
else if op \== '>' then
call err 'bad op' op 'in wshHookRedir' op || dsn
else do
if pos('>', dsn) > 0 then
parse var dsn f '>' dsn
else if verify(dsn, '.~/', 'm') > 0 then
nop
else if abbrev(dsn, 'E') | abbrev(dsn, 'VV') ,
| abbrev(dsn, 'VF') then
parse var dsn f 2 dsn
else
f = 'E'
dsn = strip(dsn)
if dsn \== '' & verify(dsn, '.~/:', 'm') == 0 then
dsn = '::'dsn
if f <> '' then
call pipe '+F', fEdit(dsn, f)
else
call pipe '+F', file(dsn)
end
m.m.pipeCnt = m.m.pipeCnt + 1
return ''
endProcedure wshHookRedir
/* copy wshCopy end ************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy comp begin ****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
**********************************************************************/
/***** initialisation ************************************************/
/*--- module initialisation -----------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = m.ut_space
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp_idChars = m.ut_alfNum'@_'
m.comp_wCatC = 'compile'
m.comp_wCatS = 'do withNew with for forWith ct proc arg if else'
m.comp_astOps = m.comp_chOp'!)&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ---------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile one unit of the source with kind ki
and return oRunner with the code -------------------------*/
compile: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
a = ''
if m.m.end \== '' then
call scanNlUntil s, '$#out'
else if ki == '*' then
call scanNlUntil s, '$#'
else
a = compUnit(m, ki, '$#')
if compIsEmpty(m, a, 0) then
return ''
cd = compAst2Rx(m, '!', a)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m, erKi
s = m.m.scan
if erKi \== '' then
if \ scanEnd(s) then
return scanErr(s, 'wsh' compKindDesc(erKi),
"expected: compile stopped before end of input")
call scanClose s
return m
endProcedure compEnd
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '¢-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code -----------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/¢') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause -----------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code --------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAst(m, '¢')
nlLe = 0 /* sophisticated logic using left and right NLs*/
do forever
one = compExprStm1(m, ki, nlLe)
if one == '' then
return compAstFree0(res)
call mAdd res, one
nlLe = scanNl(s)
end
endProcedure compExprStmts
/*--- scan over space comm nl until next
expression or statement and compile it --------------------*/
compExprStm1: procedure expose m.
parse arg m, ki, nlLe
s = m.m.scan
if pos(ki, ':%^') > 0 then do /* statements with $ are ok */
call compSpNlComment m, '*'
if ki \== ':' then do
one = compExpr(m, 's', ki)
if one \== '' then
return one
end
end
else if ki == '@' then do /* rexx statements */
call compSpNlComment m
one = compExpr(m, 's', ki)
if one\ == '' then do
if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
do forever /* scan all continued rexx lines */
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
return compAstFree0(one)
end
end
else do /* statemens need $, nl logic for expr */
do forever /* tricky logic for empty lines */
do forever
sx = m.s.pos
call scanSpaceOnly s
if \ compComment(m) then
leave
nlLe = 0
end
m.s.pos = sx
one = compExpr(m, 'd', ki)
nlRi = scanNL(s, '?')
if one == '' then do
if nlLe & nlRi then
return compAst(m, translate(ki, ';-', '@=') ,
, ,compAst(m,'='))
end
else if m.one.containsD then
return one
if \ nlRi then
leave
nlLe = scanNL(s)
end
end
return compStmt(m, ki)
endProcedure compExprStm1
/*--- compile a single statement ------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compExprStm1(m, ki, 0),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compExprStm1(m, ki, 0),
, 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compExprStm1(m, ki, 0),
, "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'withNew' then do
oldVars = m.m.comp_assVars
m.m.comp_assVars = ''
one = compCheckNN(m, compExprStm1(m, ki, 0), 'after withNew')
r = compAst(m, 'F', 'withNew', '', one,
, compAst(m, '*', '!.'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
m.m.comp_assVars = oldVars
return r
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compExprStm1(m, ki, 0), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
if fu == 'if' | fu == 'else' then do /* unchanged rexx */
call scanBack s, fu
return compExpr(m, 's', '@')
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '¢' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit -----------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '¢' then
stopper = m.comp_chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/**** lexicals *******************************************************/
/*--- skip a comment. return 0 if there is none ---------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments --------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ---------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp_wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp_wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '¢' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ***************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
¢ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ! execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
**********************************************************************/
/*--- create a new AST ----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ---------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST -------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg -------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')!') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '!') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '!' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, '!', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@!)') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,'!', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, '!', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, '!', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, '!', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, '!', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'wshHookComp( ,'args ',in2Buf())')
end
return compAstErr(a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a)
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '¢' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects ---------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp_idChars) > 0 then
if pos(rl, m.comp_idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
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
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procedure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
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
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 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 jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead 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 scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- 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-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
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
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
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 comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
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 scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'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 pipe begin ****************************************************
**********************************************************************/
pipeIni: procedure expose m.
if m.pipe_ini == 1 then
return
m.pipe_ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
m.j.out = m.pipe.ax.out
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
say '||| please use vIn instead fo vIn'
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end *****************************************************/
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
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.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
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
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
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.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
if oKindOfString(m) then
return oNew('FileList', dsn2Jcl(oAsString(m)), opt)
else
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a ----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg || copies('.*', pos('*', arg) < 1)" ,
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy db2Util begin ************************************************/
/--- return (first) list of columns from punch file
i.e. lines between first pair of ( and ) on a line
used by abub gbGr ----------------------------------------------*/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure loadCols
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' m.in
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call out ' SORTDEVT DISK '
do in()
li = m.in
if pos('CHAR(', li) > 0 then
call out strip(li, 't') 'TRUNCATE'
else if word(li, 1) word(li, 3) == 'PART INDDN' then do
call out li,
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
call out ' DISCARDDN TDISC '
end
else
call out li
end
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy sqlWsh begin **************************************************
remote SQL using csmExWsh ************************************/
sqlConClass_w: procedure expose m.
if m.sqlWsh_ini == 1 then
return m.class_SqlWshConn
m.sqlWsh_ini = 1
call sqlConClass_S
call csmIni
call classNew 'n SqlWshRdr u CsmExWsh', 'm',
, "jReset call jReset0 m; m.m.rdr = jBuf()" ,
"; m.m.rzDb=arg; m.m.sql = arg2;m.m.type= arg(3)" ,
, "jOpen call sqlWshRdrOpen m, opt"
return classNew('n SqlWshConn u', 'm',
, "sqlRdr return oNew(m.class_sqlWshRdr, m.sql_conRzDb" ,
", src, type)" ,
, "sqlsOut return sqlWshOut(rdr,m.sql_conRzDB,retOk,m.ft.opt)")
endProcedure sqlConClass_w
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshRdrOpen: procedure expose m.
parse arg m, oOpt
r = m.m.rdr
m.r.buf.0 = 1
m.r.buf.1 = m.m.sql
parse var m.m.RzDb m.m.rz '/' dbSys
m.m.wOpt = 'e sqlRdr' dbSys
call csmExWshOpen m, oOpt
d = m.m.deleg
em = ''
do while jRead(d)
if objClass(m.d) \== m.class_S then do
m.d.readIx = m.d.readIx - 1
leave
end
em = em'\n'm.d
end
if em == '' then
return m
call jClose m.m.deleg
return err('sqlWshRdr got' substr(em, 3))
endProcedure sqlWshRdrOpen
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshOut: procedure expose m.
parse arg rdr, rzDb, retOk, oo
parse value dsnCsmSys(rzDb) with rz '/' dbSys
if pos('o', oo) > 0 then
spec = 'e sqlsOut'
else
spec = 'v' || (m.wsh.outLen+4) 'sqlsOut'
call csmExWsh rz, rdr, spec dbSys oo retOk
return 1
endProcedure sqlWshOut
/* copy sqlWsh end *************************************************/
/* copy sqlS begin **************************************************
sqlStmts **********************************************/
sqlConClass_S: procedure expose m.
if m.sqlS_ini == 1 then
return m.class_SqlConnS
m.sqlS_ini = 1
call sqlConClass_R
call scanWinIni
return classNew('n SqlConnS u SqlConn', 'm',
, "sqlsOut return sqlsOutSql(rdr, retOk, ft)")
endProcedure sqlConClass_S
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt, fOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk, fOpt)
endProcedure sqlStmts
/*--- output sql as table -------------------------------------------*/
sql2tab: procedure expose m.
parse arg src, retOk, ft
cx = m.sql_defCurs
if ft == '' then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c' , '-'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c','-'ft))
call sqlQuery cx, in2str(src, ' '), retOk
call sqlFTab ft, cx
return
endProcedure sql2tab
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, ft
if ft = '' then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , 'a'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , ft))
interpret classMet(m.sql_ConCla, 'sqlsOut')
sqlsOutSql: procedure expose m.
parse arg rdr, retOk, ft
m.sql_errRet = 0
cx = m.sql_defCurs
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' | m.sql.cx.fun == 'CALL' then
if m.ft.verbose then
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
if m.sql.cx.resultSet == '' then
iterate
do until \ sqlNextResultSet(cx) | m.sql_errRet
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose then
call out sqlMsgLine(m.sql.cx.fetchCount ,
'rows fetched', , m.r)
end
end
call jClose r
if m.sql_errRet then do
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
return \ m.sql_errRet
endProcedure sqlsOutSql
/*--- sql hook ------------------------------------------------------
hook paramter db | windowSpec | db? , windowSpec? , fTabOpt?
db: dbSys, rz/dbSysAbkürzung, 1 oder 2 chars
windowSpec: 0 = variable len, 123 = window123
default spufi = window72 ---------------------*/
wshHook_S: procedure expose m.
parse arg m, spec
parse var spec ki 2 rest
call errSetSayOut 'so'
if ki == '/' then do
inp = m.m.in
end
else do
call compIni
if pos(ki, m.comp_chKind) <= 0 then do
ki = '='
rest = spec
end
inp = wshCompile(m, ki)
end
if pos('@',rest)>0 then call err 'was ist das??????' spec
if words(rest)==1 & (datatype(rest, 'n') | pos('@',rest)>0) then
rest = ','rest
parse var rest dbSy ',' wOpt ',' fOpt
d2 = ii2rzDb(dbSy, 1)
call sqlConnect d2
m.m.info = 'runSQL'
if \ sqlStmts(inp, 'rb ret', strip(wOpt), , strip(fOpt)) then do
m.m.end = 1
m.m.exitCC = 8
end
call sqlDisConnect
return ''
endProcedure wshHook_s
/*--- wshHook for sqlRdr read from dd wsh --------------------------*/
wshHook_sqlRdr: procedure expose m.
parse arg m, dbSys
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if \ m.sql_errRet then
r = sqlRdr(m.m.in)
if \ m.sql_errRet then
call jOpen r, '<'
if \ m.sql_errRet then do
call pipeWriteAll r
call jClose r
end
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
/* else
call out sqlMsgLine(m.r.bufI0 'rows fetched', , m.r.srcTxt) */
call sqlDisConnect
return ''
endProcedure wshHook_sqlRdr
/*--- wshHook for sqlsOut read from dd wsh --------------------------*/
wshHook_sqlsOut: procedure expose m.
parse arg m, dbSys oo retOk
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if oo == 'a' | oo == 't' then do
myOut = m.j.out
m.myOut.truncOk = 1
end
if \ m.sql_errRet then
call sqlsOut m.m.in, retOk, oo
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
call sqlDisConnect
return ''
endProcedure wshHook_sqlsOut
/* copy sqlS end *************************************************/
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlConClass_R: procedure expose m.
if m.sqlO_ini == 1 then
return m.class_sqlConn
m.sqlO_ini = 1
call sqlIni
call jIni
/* call scanReadIni */
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.sql = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
return classNew('n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return err('no stmts/sqlsOut in conClass_R')")
endProcedure sqlConClass_R
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg srcRdr, type
src = in2str(srcRdr, ' ')
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = m.m.sql
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys
cCla = connectionClass
e = rexx local only
r = rexx local only, rdr&objects
s = rexx local only, rdr&objects, stmts (default local)
c = with csmASql , rdr&objects
w = with sqlWsh , rdr&objects, stmts (default remote) ----*/
sqlConnect: procedure expose m.
parse arg sys, cCla
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if pos('/', sys) <= 0 then
cCla = firstNS(translate(cCla, 'rs', 'cw'), 's')
else if cCla = '' then
cCla = 'w'
if cCla == 'e' then
m.sql_conCla = 'sql E no connection class'
else
interpret 'm.sql_conCla = sqlConClass_'cCla'(sys, cCla)'
if pos(cCla, 'ers') == 0 then do
m.sql_conRzDB = sys
return
end
call sqlIni /* initialize dsnRexx */
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
m.csm_errMsg = strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
dd = tsoDD(csmDel, 'a')
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname("dd")", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname("dd")", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName("dd") member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then
return tsoFree(dd)
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call tsoFree dd
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call tsoFree dd
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
say 'please use dsnCopy instead of depreceated csmCopy'
return dsnCopy(fr, to, mbrs)
csmCop2: procedure expose m.
parse upper arg o1 o2, fr, to tA1 ':' tA2, mbrs
frDD = tsoDD('csmFrDD', 'a')
tAt = strip(tA1 firstNS(tA2, ':D'frDD))
toDD = tsoDD('csmToDD', 'a')
mbr1 = abbrev(o2, '&') & words(mbrs) = 1
if mbr1 then do
parse value strip(mbrs) with fMb '>' tMb
call csmAlloc fr'('fMb')', frDD, 'shr'
tM2 = firstNS(tMb, copies(fMb, o2 <> '&-'))
call csmAlloc dsnSetMbr(to, tM2), toDD, 'shr', , tAt
end
else do
call csmAlloc fr, frDD, 'shr'
call csmAlloc to, toDD, 'shr', , tAt
end
if m.tso_recFM.frDD <> m.tso_recFM.toDD ,
| m.tso_lRecL.frDD <> m.tso_lRecL.toDD then do
call tsoFree frDD toDD
return if(m.tso_lRecL.frDD <= m.tso_lRecL.toDD, 'W', 'T')
end
inDD = tsoDD('csmInDD', 'a')
i.0 = 0
if abbrev(o2, '&') & \ mbr1 then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = tsoDD('csmOuDD', 'a')
call dsnAlloc('dd('outDD') new ::V137')
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0),
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then
rest = insert('inder', rest, cx+2)
noRetry = retRc <> '' | nAtts | nn == ''
alRc = adrCsm('allocate' a1 rest, if(noRetry, retRc, '*'))
m.tso_dsorg.dd = subsys_dsOrg
m.tso_recFM.dd = subsys_recFM
m.tso_blkSize.dd = subsys_blkSize
m.tso_lRecL.dd = subsys_lRecL
if alRc = 0 then
return 0
m.tso_dsnNF.dd = pos('CSMSV29E DATA SET' dsnSetMbr(dsn) ,
'NOT IN CATALOG', m.tso_trap) > 0
if noRetry | \ m.tso_dsnNF.dd then
if pos('*', retRc) > 0 | wordPos(alRc, retRc) > 0 then
return alRc
else
return err(m.csm_errMsg)
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('fUnit2I('b', tracksused.1) ,
|| ',' fUnit2I('b', tracks.1)') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
csmMbrList: procedure expose m.
parse arg m, sys, dsn, msk
/* attention mbrList dataset(....)
does not cleanup proberly if dsn is NOT PO
and much later on follow errors appear
which are hard to debug| */
if dataType(dsnAlloc(sys'/'dsn, , mbrLisDD, 8), 'n') then do
say sys dsn
say m_tso_trap
m.m.dsnNF = m.tso_dsnNF.mbrLisDD
if \ m.m.dsnNF then
call err m.csm_errMsg
m.m.0 = -99
end
else do
m.m.dsnNF = 0
m.m.RECFM = m.tso_RECFM.mbrLisDD
m.m.LRECL = m.tso_LRECL.mbrLisDD
m.m.BLKSIZE = m.tso_BLKSIZE.mbrLisDD
m.m.DSORG = m.tso_DSORG.mbrLisDD
if m.m.DSORG \== 'PO' then
m.m.0 = -98
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
call adrCsm "mbrList ddName(mbrLisDD)" msk ,
"index(' ') short"
m.m.0 = mbr_name.0
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
end
call tsoFree mbrLisDD
end
return m.m.0
endProcedure csmMbrList
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
---------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) -------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, cmd, retOk
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
tsoRc = adrtso("csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*")
if tsoRc <> 0 then
m.csm_exRxRc = tsoRc
else
m.csm_exRxRc = appc_rc
m.csm_exRx.0 = 0
if m.csm_exRxRc <> 0 then do /* handle csm error */
call mAdd csm_exRx, 'csmExRx tsoRc='tsoRc 'appc_rc='appc_rc ,
, ' rexx rz='rz 'proc='proc 'opt='opt'\n cmd='cmd ,
, ' appc_rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f ,
, ' SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ix=1 to appc_msg.0
call mAdd csm_exRx, ' ' appc_msg.ix
end
if tsoRc = 0 then
call mAdd csm_exRx ' rc=0 for tsoCmd' m.tso_stmt
else
call splitNl csm_exRx, m.csm_exRx.0,
, 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
call readDD 'rmTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmtsPrt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
call mAddSt csm_exRx, csm_tsprt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call mStrip csm_exRx, 't'
call saySt csm_exRx */
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call saySt csm_exRx
else
call csmExRxErr
end
return m.csm_exRxRc
endProcedure csmExRx
/*--- error for last csmExRx ----------------------------------------*/
csmExRxErr: procedure expose m.
call outSt csm_exRx
call err m.csm_exRx.1
return
endProcedure csmExRxErr
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmTsPrt ' ,
'rmtwsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = oOpt
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
if length(o2) > 1 then do
/* without blkSize csm will fail to read for rec < 272 */
parse upper var o2 oA 2 oB
if datatype(oB, 'n') then do
blk = 32760
if oA == 'F' then
blk = blk - blk // oB
say '???? ::'o2 '==> blkSize('blk')'
o2 = o2 'blkSize('blk')'
end
end
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec, '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH' wSpec, '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc, 0 4) < 1 then call csmExRxErr;" ,
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end ******************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP RQ2/DVBP' ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP Q25/DVBP' ,
'Z25/DEVG Y25/DEVG X25/DEVG'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful tsoDD , - should be ok */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m_tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy csv begin ****************************************************/
/**** csvRdr reads a text file, in csv format
and creates a class from column head in first line
csvRdr#jRead returns the create objects ************************/
csv2ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv2ObjRdr', 'm.m.opt = arg2' ,
, 'call csv2ObjBegin m' ,
, 'call csv2Obj m, rStem, $i'), rdr, opt)
csv2ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return m
endProcedure csvRdrOpenFinish
csv2Obj: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(translate(li, ' ', ','), 1))
call mAdd wStem, csv2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csv2Obj
/*--- convert csv line into object of class cl ----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
/*--- clear remaining fields and stems and mutate -------------------*/
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/**** csvWordRdr: similar to csvRdr, but input line format
are quoted or unquoted words ****************************/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvWordRdr', 'm.m.opt = arg2' ,
, 'call csvWordBegin m' ,
, 'call csvWord m, rStem, $i'), rdr, opt)
csvWordBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvWord: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(li, 1))
call mAdd wStem, csvWord2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csvWord
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWord2O
/**** csvColRdr: similar to csvRdr, but input format
are fixed width columns *********************************/
/*--- create object for fixLenColumns format ------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvColRdr', 'm.m.opt = arg2' ,
, 'call csvColBegin m' ,
, 'call csvCol m, rStem, $i'), rdr, opt)
csvColBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvCol: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then do
s = scanSrc(csv_colOpen, li)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
end
call mAdd wStem, csvCol2O(m, mNew(m.m.class), m.m.class, li)
return
endProcedure csvCol
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- csv4obj add a header line
and objects of the same class in csv format ---------------*/
csv4ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv4ObjRdr', ,
, 'call csv4ObjBegin m' ,
, 'call csv4Obj m, rStem, $i'), rdr, opt)
csv4ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
endProcedure csv4ObjBegin
csv4Obj: procedure expose m.
parse arg m, wStem, o
if o == '' then do
if m.m.class \== '' then
call mAdd wStem, ''
return
end
cl = objClass(o)
if cl \== m.m.class then do
if m.m.class \== '' then
return err('class('o')='cl '<>' m.m.class)
m.m.class = cl
ff = classMet(cl, 'oFlds')
if m.ff.0 < 1 then
return err('no fields in' cl)
t = ''
do fx=1 to m.ff.0
t = t','m.ff.fx
end
call mAdd wStem, substr(t, 2)
m.m.oFldD = classMet(cl, 'oFldD')
end
call mAdd wStem, csv4O(o, m.m.oFldD, 0)
return
endProcedure csv4Obj
/*--- return the csv string for an object ---------------------------*/
csv4o: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 == oNull then
res = res','
else if pos(',', v1) > 0 | pos('"', v1) > 0 | v1 == '' then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4o
/*--- fill empty fieldds with value of previous row -----------------*/
csvE2PrevRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvE2PrevRdr', 'm.m.opt = arg2' ,
, "m.m.prev = ''" ,
, 'call csvE2Prev m, rStem, $i'), rdr, opt)
/*--- externalize o and add to wStem --------------------------------*/
csvE2Prev: procedure expose m.
parse arg m, wStem, o
if o == '' then
return
ff = oFldD(o)
hasData = 0
do fx=1 to m.ff.0
f1 = o || m.ff.fx
if m.f1 \== '' then do
hasData = 1
iterate
end
if m.m.prev == '' then
iterate
p1 = m.m.prev || m.ff.fx
m.f1 = m.p1
end
if \ hasData then
return
call mAdd wStem, o
m.m.prev = o
return
endProcedure csvE2Prev
csvColBegin: procedure expose m.
/**** csvExt externalises object into csvExt format
including object cycles and classes
csv+ protocoll, first field contains meta info ---------------------
v,text null or string
w,text w-string
c name classAdr,flds class definition
b name classAdr, class forward declaration
m name adr,text method
o classAdr adr,flds object definition and output
d classAdr adr,flds object definition wihtout output
f classAdr adr, object forward declaration
r adr, reference = output of already defined objects
* text unchanged text including ' " ...
* flds csv flds
**********************************************************************/
csvExtRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvExtRdr', ,
, 'call csvExtBegin m',
, 'call csvExt m, rStem, $i'), rdr, opt)
csvExtBegin: procedure expose m.
parse arg m
d = m'.DONE'
call mapReset d, 'K'
call mapPut d, m.class_class, 'class'
call mapPut d, m.class_v, 'v'
call mapPut d, m.class_w, 'w'
call mapPut d, m.class_o, 'o'
return m
endProcedure csvExtBegin
/*--- externalize o and add to wStem --------------------------------*/
csvExt: procedure expose m.
parse arg m, wStem, o
c = objClass(o)
if c == m.class_W then
return mAdd(wStem, 'w,'substr(o, 2))
if oKindOfString(o) then
return mAdd(wStem, 'v,'o)
if c == m.class_class then
call csvExtClass m, wStem, o
if m.m.done.o == 0 then do
m.m.done.o = 1
call mAdd wStem, 'f' csvExtClass(m, wStem, c) o','
end
if symbol('m.m.done.o') == 'VAR' then
return mAdd(wStem, 'r' o',')
return mAdd(wStem, 'o' c o || csvExtObjTx(m, wStem, o))
endProcedure csvExt
csvExtObjTx: procedure expose m.
parse arg m, wStem, o
call mapAdd m'.DONE', o, 0
c = objClass(o)
if c \== m.class_class & pos(m.m.done.c, 12) < 1 then
call csvExtClass m, wStem, c
ff = classMet(c, 'oFldD')
r = ''
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then do
v1 = s2o(v1)
end
else if \ (c2 == m.class_N | c2 == m.class_W) then do
if m.m.done.v1 == 0 then do
m.m.done.v1 = 1
call mAdd wStem, 'f' c2 v1','
end
if symbol('m.m.done.v1') \== 'VAR' then
call mAdd wStem, 'd' c2 v1 ,
|| csvExtObjTx(m, wStem, v1)
end
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
m.m.done.o = 2
return r
endProcedure csvExtObjTx
csvExtClass: procedure expose m.
parse arg m, wStem, c
res = mapGet(m'.DONE', c, '-')
if res == 0 then do
m.m.done.c = 1
call mAdd wStem, 'b' if(m.c.name == '', '-', m.c.name) c','
return c
end
if res == 1 then
return c
if res \== '-' then
return res
call mapAdd m'.DONE', c, 0
ty = m.c
res = if(m.c.name == '', '-', m.c.name) c
if ty == 'u' then do
res = 'c' res',u'
if m.c.0 > 0 then do
r = ''
do cx=1 to m.c.0
r = r','csvExtClassEx(m, wStem, m.c.cx)
end
res = res substr(r, 2)
end
end
else if ty == 'm' & m.c.0 == 0 then
res = 'm' res','m.c.met
else
res = 'c' res','csvExtClassEx(m, wStem, c)
call mAdd wStem, res
call mapPut m'.DONE', c, c
return c
endProcedure csvExtClass
csvExtClassEx: procedure expose m.
parse arg m, wStem, c
res = ''
ch = c
do forever
g = mapGet(m'.DONE', c, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res csvExtClass(m, wStem, ch))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('csvExtClassEx bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure csvExtClassEx
/*--- convert variable len recs to fixLen
& = continuation, | end (to protect ' &|') -------------------*/
csvV2FRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvV2FRdr', 'm.m.maxLen = arg2',
, 'call csvV2FBegin m, m.m.maxLen',
, 'call csvV2F m, rStem, $i'), rdr, arg)
csvV2FBegin: procedure expose m.
parse arg m, maxL
m.m.maxLen = word(maxL 55e55, 1)
return m
endProcedure csvV2FBegin
csvV2F: procedure expose m.
parse arg m, wStem, line
if line \== '' & pos(right(line, 1), ' &|') > 0 then
line = line'|'
if length(line) <= m.m.maxLen then
return mAdd(wStem, line)
do cx=1 by m.m.maxLen-1 to length(line)-m.m.maxLen
call mAdd wStem, substr(line, cx, m.m.maxLen-1)'&'
end
return mAdd(wStem, substr(line, cx))
endProcedure csvV2F
/*--- f2v fixLen to variable len lines: &=continuation |=endMark ----*/
csvF2VRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvF2VRdr', ,
, 'call csvF2VBegin m' ,
, 'call csvF2V m, rStem, $i' ,
, 'call csvF2VEnd m'), rdr, arg)
csvF2VBegin: procedure expose m.
parse arg m
m.m.strt = ''
return m
endProcedure csvF2VBegin
csvF2V: procedure expose m.
parse arg m, wStem, aLi
li = strip(aLi, 't')
if right(li, 1) == '&' then do
m.m.strt = m.m.strt || left(li, length(li) - 1)
return
end
if right(li, 1) == '|' then
call mAdd wStem, m.m.strt || left(li, length(li) - 1)
else
call mAdd wStem, m.m.strt || li
m.m.strt = ''
return
endProcedure csvF2V
csvF2VEnd: procedure expose m.
parse arg m
if m.m.strt \== '' then
return err("csvF2vEnd but strt='"m.m.strt"'")
return m
endProcedure csvF2VEnd
/*--- internalize objects in ext format -----------------------------*/
csvIntRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvIntRdr', ,
, 'call csvIntBegin m',
, 'call csvInt m, rStem, $i'), rdr, opt)
csvIntBegin: procedure expose m.
parse arg m
m.m.forward = ''
d = m'.DONE'
call mapReset d, 'K'
return
endProcedure csvIntBegin
csvInt: procedure expose m.
parse arg m, wStem, line
parse var line hd ',' rest
parse var hd h1 h2 h3 hr
d = m'.DONE'
if pos(h1, 'vwr') > 0 then do
if m.m.forward \== '' then
return err('csvInt: forward='m.m.forward 'not empty:' line)
if h1 == 'v' & h2 == '' then
return mAdd(wStem, rest)
if h1 == 'w' & h2 == '' then
return mAdd(wStem, m.o_escW || rest)
if h1 \== 'r' | h2 == '' | h3 \== '' | rest \== '' then
return err('csvInt: bad line' line)
r = mapGet(d, h2, '')
if r == '' then
return err('csvInt: undefined reference' line)
return mAdd(wStem, r)
end
if h3=='' | hr\=='' | length(h1)\==1 | pos(h1, 'bcmdfo') < 1 then
return err('csvInt: bad line' line)
if h1 == 'b' | h1 == 'f' then do
if symbol('m.d.h3') == 'VAR' then
return err('csvInt: forward already defined:' line)
if h1 == 'b' then do
if h2 == '-' then
h2 = 'CsvForward'
n = classNew('n' h2 || (m.class.0+1) 'u')
m.n.met = h2'*'
end
else do
cl = mapGet(d, h2, '')
if cl == '' then
return err('csvInt: undefined class:' line)
n = mNew(cl)
end
call mapAdd d, h3, n
m.m.forward = m.m.forward h3
return
end
if h1 == 'm' then do
n = classNew('m' h2 rest)
return mapAdd(d, h3, n)
end
if h1 == 'c' then do
rx = 1
rr = ''
do while rx <= length(rest)
ry = pos(',', rest, rx+1)
if ry < 1 then
ry = length(rest)+1
r1 = substr(rest, rx, ry-rx)
rI = wordIndex(r1, words(r1))
if rI == 1 & abbrev(r1, ',') then
rI = 2
rL = strip(substr(r1, rI))
if length(rL) \== 1 | pos(rL, 'vwor') < 1 then do
rL = mapGet(d, rL, '')
if rL == '' then
return err('csvInt undef class' rL 'line:' line)
end
rr = rr || left(r1, rI-1)rL
rx = ry
end
end
fx = wordPos(h3, m.m.forward)
if fx > 0 then do
m.m.forward = strip(delWord(m.m.forward, fx, 1))
n = mapGet(d, h3)
if h1 == 'c' then do
call classNew 'n=' m.n.name rr
call classMet n, 'new'
return
end
cl = 'CLASS'substr(n, 2, pos('.', n, 3)-2)
if cl \== mapGet(d, h2) then
return err('csvInt: forward class' cl 'mismatches' line)
end
else do
if mapHasKey(m, d, h3) then
return err('already defined:' line)
if h1 == 'c' then do
do while datatype(right(h2, 1), 'n')
h2 = left(h2, length(h2)-1)
end
if h2 == '-' then
h2 = 'CsvForward'
s = ''
cl = classNew(copies('n*' h2' ', h2 \== '-')rr)
call classMet cl, 'new'
return mapAdd(d, h3, cl)
end
cl = mapGet(d, h2, '')
if cl == '' then
return err('undefined class:' line)
n = mNew(cl)
call mapAdd d, h3, n
end
call csv2o n, cl, rest
ff = classFldD(cl)
do fx=1 to m.ff.0
f1 = n || m.ff.fx
c1 = m.ff.fx.class
if m.c1 \== 'r' | m.f1 == '' | abbrev(m.f1, m.o_escW) then
iterate
t1 = mapGet(d, m.f1, '')
if t1 == '' then
return err('missing reference' fx m.f1 'in' line)
m.f1 = t1
end
if h1 == 'o' then do
if m.m.forward \== '' then
call err 'forward not empty:' line
call mAdd wStem, n
end
return
endProcedure csvInt
/* copy csv end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'" ,
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 <> 0" ,
"| m.qStem.0 < m.m.bufMax / 2 then do;" ,
"call mAddSt m''.BUF'', qStem;" ,
"if m.m.buf.0 > m.m.bufMax then do;'" ,
"classMet(cl, 'jWriteMax')'; end; end;",
"else do; wStem = qStem;' classMet(cl, 'jWrite') ';end'",
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
return classInheritsOf(objClass(obj), sup)
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return true if obj is kind of string -------------------------*/
oKindOfString: procedure expose m.
parse arg obj
return objMet(obj, 'oKindOfString')
/*--- if obj is kindOfString return string
otherwise return arg(2) or fail ---------------------------*/
oAsString: procedure expose m.
parse arg m
interpret objMet(m, 'oAsString')
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
/* copy o end ********************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "asString return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "asString return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "oKindOfString return classMet(cl, 'asString', '\-\')" ,
"\== '\-\'" ,
, "oAsString if classMet(cl, 'oKindOfString')" ,
"then return classMet(cl, 'asString');",
"else return 'if arg() >= 2 then return arg(2)" ,
"; else return err(m ''is not a kind of string" ,
"but has class' className(cl)''')'" ,
, "o2String return classMet(cl,'asString','\-\')" ,
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
m.class_S = classNew('n String u', 'm',
, 'asString return m' ,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, "asString return ''",
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
call mPut class_inheritMet'.'m.class_V, 0
call mPut class_inheritMet'.'m.class_W, 0
call mPut class_inheritMet'.'m.class_O, 0
call mPut class_inheritMet'.'m.class_S, 0
call mPut class_inheritMet'.'m.class_N, 0
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0 /* methods directly in cl */
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0 /* inherited methods */
cl = m.aC.cx
if m.cl == 'u' & m.class_inheritMet.cl \== 0 then
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class 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
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* 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>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy fTab begin ****************************************************
output Modes: t = tableMode 1 line per object with fixed colums th
c = colMode 1 line per column/field of object
we build a format for each column
and a set of title lines, one sequence printed before
, one sequence printed after
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * fTabAdd * add col info
sqlFTabOthers ?
fTabGenTab or fTabGenCol
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
primary data for each col
.col : column (rexx) name plus aDone
.done : == 0 sqlFtabOthers should add it again
.fmt : format
.labelLo : long label for multi line cycle titles
.labelSh : short label for singel title line (colwidth)
.tit.* : title line piece for this col
**********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.verbose = pos('s', m.m.opt) < 1 /* not silent */
m.m.0 = 0
m.m.set.0 = 0
return fTabResetCols(oMutate(m, m.fTab_class))
endProcedure fTabReset
/*--- clean out all cols of ftab, but keep settings -----------------*/
fTabResetCols: procedure expose m.
parse arg m
m.m.0 = 0
return m
/*--- for column cx set title tx ------------------------------------*/
fTabSetTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if tx > m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabSetTit
/*--- set default atts for a col name ------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, sh, lo
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelSh = sh
m.m.set.sx.labelLo = lo
m.m.set.c1 = sx
return
endProcedure fTabSet
/*--- add a column --------------------------------------------------
m, rexxName done, fmt, labelShort, labelLong, titles... ------*/
fTabAdd: procedure expose m.
parse arg m, rxNm aDone
m.m.generated = ''
cx = m.m.0 + 1
m.m.0 = cx
cc = m'.'cx
m.cc.col = rxNm
m.cc.done = aDone \== 0
parse arg , , m.cc.fmt, m.cc.labelSh, m.cc.labelLo
if rxNm == '=' | rxNm == 0 | rxNm == 1 then
call err 'bad rxNm' rxNm
if \ (aDone == '' | aDone == 0 | aDone == 1) then
call err 'bad aDone' aDone
m.cc.tit.0 = max(arg()-4, 1)
m.cc.tit.1 = ''
do tx=2 to m.cc.tit.0
m.cc.tit.tx = arg(tx+4)
end
return cc
endProcedure fTabAdd
/*--- complete column info-------------------------------------------*/
fTabColComplete: procedure expose m.
parse arg m
do cx=1 to m.m.0
nm = m.m.cx.col
f1 = m.m.cx.fmt
if f1 = '' then
m.m.cx.fmt = '@.'nm'%-8C'
else do
px = pos('%', f1)
ax = pos('@', f1)
if px > 0 & (ax <= 0 | ax >= px) then
m.m.cx.fmt = left(f1, px-1)'@.'nm || substr(f1, px)
end
if m.m.cx.labelLo = '' then
if nm = '' then
m.m.cx.labelLo = '='
else
m.m.cx.labelLo = nm
if m.m.cx.labelSh = '' then
m.m.cx.labelSh = m.m.cx.labelLo
end
return
endProcedure fTabColComplete
/*--- generate line formats and title lines -------------------------*/
fTabGenTab: procedure expose m.
parse arg m, sep
if m.m.generated == '' then
call fTabColComplete m
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
f = ''
tLen = 0
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelSh
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelSh) < 1 then /* corrupted| */
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelSh, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fGen('%>', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
/*try with cycle lines for cSta to cEnd */
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelLo
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelLo
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelLo) ,
= translate(m.m.kx.labelSh)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenTab
/*--- generate column format ----------------------------------------*/
fTabGenCol: procedure expose m.
parse arg m
if m.m.generated == '' then
call fTabColComplete m
do kx=1 to m.m.0
t = m.m.kx.labelLo
l = if(m.m.kx.labelSh == t, , m.m.kx.labelSh)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabGenCol
/*--- output all of rdr in tab format -------------------------------*/
fTab: procedure expose m.
parse arg m, rdr
if pos('a', m.m.opt) < 1 then
i = rdr
else do
i = in2Buf(rdr)
if m.i.buf.0 > 0 then
call fTabDetect m, i'.BUF'
end
if pos('o', m.m.opt) > 0 then do
call pipeWriteAll i
end
else if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
i = jOpen(in2file(i), '<')
do rx=1 while jRead(i)
call out left('--- row' rx '', 80, '-')
call fTabCol m, m.i
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
call jClose i
end
else do
call fTabBegin m
call fAll m.m.fmt, i
return fTabEnd(m)
end
return m
endProcedure fTab
/*--- output object i in col format ---------------------------------*/
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenTab m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr
if m == '' then
m = fTabReset(f_auto, 1, , 'a')
else if pos('a', m.m.opt) < 1 then
m.m.opt = 'a'm.m.opt
return fTab(m, rdr)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
do cx=1 to m.m.0
rxNm = m.m.cx.col
done.rxNm = m.m.cx.done
if m.m.cx.fmt == '' then
m.m.cx.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
rxNm = substr(m.ff.fx, 2)
if done.rxNm \== 1 then do
cc = fTabAdd(m, rxNm)
m.cc.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabDetectFmt: procedure expose m.
parse arg st, suf
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
return '%'newFo
endProcedure fTabDetectFmt
/* copy fTab end ***************************************************/
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"¢"pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
/* special L = LRSN in Hex
l = lrsn (6 or 10 Byte) */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
m.f_tstScan = 0
a = 'F_TSTFO.'
/* Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplement
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X
qr: minuten//10, sec ==> aa - xy base 25 */
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGen(cd, s)
end
if c == ' ' then do
if pos(d, 'SN') > 0 then
return fTstGen('N'd, "date('S') time('L')")
else if pos(d, 'sMAn ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeY') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
call err "fTstGe2 implement ' '->"d
end
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic t for source s ------------------------------*/
fTstgFF: procedure expose m.
parse arg f, t, s
if verify(f, 'lLjJu', 'm') > 0 then do /* special cases */
if f == 'l' then do
if t == 'l' then
return 'timeLrsn10('s')'
else if t == 'L' then
return 'c2x(timeLrsn10('s'))'
else if verify(t, 'lL', 'm') = 0 then
return fTstFi(m.fTst_fo.S, t, 'timeLrsn2LZT('s')')
end
call err 'fTstgFF implement' f 'to' t
end
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, t
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: ------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_uc25 = left(m.ut_uc, 25)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/
}¢--- A540769.WK.REXX(ABUBEXP) cre=2014-03-28 mod=2016-01-04-11.11.26 A540769 ---
$#@
$** export contents of abub rule
call sqlConnect dp4g
$;
$>. fEdit()
$@%¢expTb - 'oa1p.tQZ046AbUbRule', , 'abub rule'$!
$@proc expTb $@/expTb/
parse arg , tb, wh, tit
$$- ''
$$- '---------------' tit
$$- '-- delete from' tb copies('where' wh, wh \== '')
$$ ;
$;
call sqlSel 'select * from' tb copies('where' wh, wh \== '')
$|
lst = ''
cx = 0
$@for oo $@¢
cx = cx + 1
o1 = $.oo
call sql4Obj o1, tb
if wordPos(m.o1.name, lst) < 1 then
lst = lst m.o1.name
$!
say right(cx, 5) 'inserts into' left(tb, 24) 'for' tit
$=names=- lst
$/expTb/
$#out 20160104 11:08:54
$#out 20140328 08:29:29
}¢--- A540769.WK.REXX(AC) cre=2013-01-24 mod=2013-01-24-13.46.41 A540769 -------
/* rexx --------------------------------------------------------24. 1.13
edit macro fuer bessere Darstellung Analysis
Labels
.a erstes Connect
.s Snapshot
.c Change analysis Report
----------------------------------------------------------------------*/
call errReset 'hi'
if adrEdit('macro (args)', ) <> 0 then
call errHelp 'bitte als EditMacro aufrufen (ohne TSO praefix|)'
if pos('?', args) > 0 then
call help
if adrEdit("find first .connect 1", 4) = 4 then
call err 'kein .connect, ist das wirklich eine CA Analyse?'
call adrEdit "(con) = cursor"
call adrEdit "label" con "= .a 0", 8
call adrEdit "exclude p'=' .zf .a all", 0 4
call adrEdit "xstatus .a = nx", 0 4
if adrEdit("find first '.call snapshot' 1", 4) = 0 then do
call adrEdit "(sna) = cursor"
call adrEdit "label" sna "= .s 0", 8
if adrEdit("find '.FREE FI(RCVRFILE)'", 4) = 0 then do
call adrEdit "(ex) = cursor"
call adrEdit "label" (ex) "= .ex", 8
call adrEdit "exclude p'=' .s .ex all", 0 4
call adrEdit "xstatus .s = nx", 0 4
end
end
if adrEdit("find first 'CHANGE ANALYSIS REPORT'", 4) = 0 then do
call adrEdit "(rep) = cursor"
call adrEdit "label" rep "= .c 0", 8
end
call adrEdit "cursor = .a"
call adrEdit "locate .a"
exit
/* 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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- 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 ax=1 to arg()
say ' ' arg(ax)
end
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 *****************************************************/
}¢--- A540769.WK.REXX(ADRISP) cre=2016-07-11 mod=2016-07-11-11.46.32 A540769 ---
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
}¢--- A540769.WK.REXX(ADRTSO) cre=2016-09-30 mod=2016-09-30-09.58.31 A540769 ---
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
}¢--- A540769.WK.REXX(ALIB) cre=2009-04-21 mod=2011-09-08-10.38.32 A540769 -----
/* rexx **************************************************************
aLib: activate and deactivate tso and ispf libraries.
synopsis: alib ¢-OPTIONS!... ¢DSN!... ...
Options designating the Libaries to activate/deactivate
opt LLQ def Library
-e EXEC TSO EXEC Library: altlib application(exec)
-r REXX TSO EXEC Library: altlib application(exec)
-f LOAD TSO TSOLIB (warning: must be pushed on tso stack
and will only be processed when rexx finishes)
-p PANELS ISPPLIB: ispf panels
-m MSGS ISPMLIB: ispf messages
-t TABLES ISPTLIB: ispf tables input
-u TABLES ISPTABL: ispf tables update
-s SKELS ISPSLIB: ispf skeletons
-l LOAD ISPLLIB: ispf load
other standalone options:
-a activate (default)
-d deactivate
-? or ? for this help
options taking values:
-q<llqs> LowLevelQualifiers, with <llqs> one of the following
* the default LLQ from above (default)
empty no llq
list a comma separated list of llqs
-c<application> if nonEmpty dsn is interpreted
as a ChangeMan PackageNumber of this application
otherwise as a (tso) datasetName (the default)
***********************************************************************/
defLib = wk
self = defLib'.REXX(ALIB)'
info = ' PPLIBPANELS MMLIBMSGS TTLIBTABLES UTABLTABLES SSLIBSKELS' ,
' LLLIBLOAD ETSOAEXEC RTSOAREXX FTSOLLOAD'
do ix=1 to words(info)
op = left(word(info, ix), 1)
libs.op = ''
end
libs = 'R'
newLibs = ''
fun = 'activate'
llq = '*'
cMan = ''
rexxLib = 'A540769.WK.REXX'
skels = rexxLib'.SKELS'
parse arg mainArgs
call errReset 'hi'
if mainArgs = '' then
call adrEdit 'macro (mainArgs)', '*'
if mainArgs == 'returnRexxlib' then
return rexxLib
else if mainArgs == 'returnRexxlibSkels' then
return rexxLib skels
say self 'start args' mainArgs
mainArgs = translate(mainArgs)
dsnCnt = 0
do wx=1 by 1
w = word(mainArgs, wx)
if w = '' then do
if dsnCnt = 0 then
w = defLib
else
leave
end
if pos('?', w) > 0 then do
return help()
return
end
else if left(w,1) = '-' then do /* options */
if w = '-' then do
fun = 'deactivate'
iterate
end
do cx=2 to length(w) /* each option */
ch = substr(w, cx, 1)
if ch = '?' then
call help
else if ch = 'A' then
fun = 'activate'
else if ch = 'D' then
fun = 'deactivate'
else if ch = 'C' then do
cMan = substr(w, cx+1)
leave
end
else if ch = 'Q' then do
llq = translate(substr(w, cx+1), ' ', ',')
leave
end
else if pos(' ' || ch, info) > 0 then
newLibs = newLibs || ch
else
call errHelp 'bad option' ch 'in' w
end /* do each option character */
end
else do /* operands */
dsnCnt = dsnCnt + 1
if newLibs <> '' then do
libs = newLibs
newLibs = ''
end
if cMan = '' then
pref = dsn2jcl(w, 1)
else
pref = "CMN.DIV.P0."cMan".#"right(w, 6, '0')
do cx = 1 to length(libs) /* each lib */
op = substr(libs, cx, 1)
if llq = '' then
libs.op = libs.op "'"pref"'"
else if llq = '*' then do
ii = word(substr(info, pos(' '||op, info)), 1)
libs.op = libs.op "'"pref'.'substr(ii, 6)"'"
end
else do
do lx=1 to words(llq)
lw = word(llq, lx)
libs.op = libs.op "'"pref '.'lw"'"
end
end
end /* do each lib */
end
end /* do each word */
nok = ''
do ix=1 to words(info)
ii = word(info, ix)
op = left(ii, 1)
if libs.op = '' then
iterate
/* say fun op ii libs.op */
if substr(ii, 2, 4) = 'TSOA' then do
c = 'altlib' fun 'application(exec)'
if fun = 'activate' then
c = c "dataset("libs.op") UNCOND"
call adrTso c
end
else if substr(ii, 2, 4) = 'TSOL' then do
c = 'tsolib' fun
if fun = 'activate' then
c = c "dataset("libs.op") UNCOND"
push c
end
else do
c = 'libdef ISP'substr(ii, 2, 4)
if fun = 'activate' then
c = c "dataset id("strip(libs.op)") UNCOND"
if 0 <> adrIsp(c, '*') then
nok = nok op'='substr(ii, 2, 4)'='rc
end
say /* fun op */ 'rc' rc c
end
if nok <> '' then
say 'alib' fun 'errors for' nok
exit
/* 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
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
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
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
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
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
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
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd
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 to 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
leave
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
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
return atts '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
/* 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
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
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
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(ALIB222) cre=2013-09-09 mod=2013-09-09-08.19.50 A540769 ---
/* rexx ---------------------------------------------------------------
caDb2: start the ca tools with cs Libraries
options d: debug, say which libraries
w: with test and personal work libs (wk.rexx ...)
t: with test libs (dsn.cadb2.cs.execTst ...)
: with prod libs (dsn.cadb2.cs.exec)
---------------------------------------------------------------------*/
parse arg args
parse source . . self . selfLib .
trace ?r
say self 'in' selfLib
m.pre = 'dsn.db2'
if self = 'ALIB' then do
if args = '-' then
return deactLibs()
else
return actLibs()
end
call actLibs
interpret 'call' self 'args'
res = result
cal deactLibs
return res
actLibs: procedure expose m.
call adrTso "ALTLIB ACTIVATE APPLICATION(EXEC)",
"DATASET('"m.pre".exec') stack"
call adrIsp "libDef ispPLib dataset",
"id('"m.pre".panel') stack"
return
endProcedure actLibs
deactLibs: procedure expose m.
call adrTso "ALTLIB DEACTIVATE APPLICATION(EXEC)"
call adrIsp "libDef ispPLib"
return
endProcedure deactLibs
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'o' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'a' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
if m.err.eCat <> '' then do
parse source . . ggS3 . /* current rexx */
pTxt = ',error,fatal error,input error,syntax error,warning,'
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
msg = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1) ,
'in' ggS3':' msg
end
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(ANAPOSMI) cre=2015-11-21 mod=2015-11-21-16.15.43 A540769 ---
$#@
$<~wk.text(rebmiss)
$>~wk.texv(rebmiss)
call sqlConnect dbof
$for i $@¢
i = strip($i)
if abbrev(i, 'NEW: ') then $@¢
mbr = dsnGetMbr(word(i, 2))
iterate
$!
if \ abbrev(i, 'I - --rebindMiss ') then
call err 'bad line' i
parse value word(i, 4) with co '.' pk ':' ve
r = sql2One( ,
"select collid, name, version, type" ,
", p.validate || p.isolation || p.valid||p.operative vivo",
", p.contoken, p.timestamp, p.timestamp, p.lastUsed" ,
", case when lastUsed>current date-10 days then 'last'",
"when timestamp>current timestamp-7 days then 'creT'",
"when not exists (select 1" ,
"from sysibm.syspackage r" ,
"where r.location=p.location and r.collid=p.collid",
"and r.name = p.name" ,
"and r.timestamp > p.timestamp" ,
"and r.timestamp <= current timestamp - 7 days)",
"then 'new7' else 'no' end doRb",
"from sysibm.sysPackage p",
"where location = '' and collid = '"co"'" ,
"and name = '"pk"' and version = '"ve"'", o, , , '----')
if abbrev(r, '-') then
$$- r mbr co'.'pk'.'ve
else if m.o.collid <> co | m.o.name <> pk | m.o.version <> ve then
$$- m.o.collid'<>'co m.o.name '<>' pk m.o.version '<>' ve
else
$$- m.o.doRb mbr m.o.collid'.'m.o.name'.'m.o.version m.o.type $*+
m.o.vivo m.o.lastUsed m.o.timestamp
$!
}¢--- A540769.WK.REXX(ANAPOST) cre=2012-12-04 mod=2016-08-30-09.49.46 A540769 ---
/* rexx anaPost -------------------------------------------------------
walter 24. 8.16
functions:
pre: preProcess ddl before analysis
ana: prostprocess analysis
rec: prostprocess recoveryAnalysis
exe: copy executionJcl from DD exe
what it does
add chkStart at beginning of analysis
disallow unchanged execution of recovery ana
add anaPost after snapshot
map tables to db.ts from unload model comments
add -sta rw AFTER drop tables
History:
24. 8.16 Walter global temporary tables
----------------------*/ /* end of help -------------------------------
8. 8.16 Walter new copies, remove unnecessary copies
9. 6.16 Walter new function DDL: overrite ddl: dsSize 4Gfor PBG
avoid segsize 32 alter to UTS/PBG
3. 6.16 Walter in pre do not allow fallback from uts to nonUts
30. 5.16 Walter move -sta rw after drop table: drop seems to work in RO
15. 4.16 Walter do not multiply alters for second and later TS ....
8. 2.16 Walter avoid pieceSize change for ddlchange of UTS
3. 2.16 Walter rebind also function packages / maxRows toEnd auch -
2. 2.16 Walter anapre/post: move alter segSize to end for UTS change
19. 1.16 Walter anapost: fix alter part for indexes
11. 1.16 Walter anapost: rdl from ALL objects
14.12.15 Walter String Constant (label) from 300 to 1500 chars extended
10.11.15 Walter redesign
22. 6.15 Walter lange Table names mit Line overflows
3.11.14 Walter archiviert dby....anO, anP, reO und reP
4. 2.14 Walter spanned unloads fuer TS mit LOBS oder XML
27.11.13 Walter sync bad sequence in recovery only warning
12. 6.13 Walter remove " from drop table names
12. 6.13 Walter fastUnload und Sync
4. 4.13 Walter check auf noUnloads
4. 4.13 Walter checkErr mit override aus option member
. 2.13 Walter neu
---------------------------------------------------------------------*/
parse arg mArg
call ini
say 'anaPost v3.4 24. 8.16 arg='space(mArg, 1)
if mArg <> '' then
exit workMain(mArg)
if 0 then
call err 'no arguments'
if 0 then do
call workFun 'PRE', 'DP4G', SV100211 ,
, 'A540769.tmp.text(sv100211)' ,
, 'A540769.TMP.TEXT(QTQZ01OP)' ,
, 0 , 'A540769.TMP.TEXT(QTQZ01PR)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
exit err('tstEnd')
%ANAPOST PRE DP4G DSN.DBXDP4G.DD2(QTQZ0100) +
DSN.DBXDP4G.AOPT(QTQZ0100) +
DSN.DBXDP4G.DDI(QTQZ0100)
end
if 1 then do
call workFun 'ANA', 'DP4G', QTQZ0100 ,
, 'DSN.DBXDP4G.AN1(QTQZ0100)' ,
, 'A540769.TMP.TEXT(QTQZ01OP)' ,
, 0 , 'A540769.TMP.TEXT(QTQZ01AN)' ,
, 'A540769.TMP.TEXT(QTQZ01QU)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
exit err('tstEnd')
%ANAPOST ANA DP4G DSN.DBXDP4G.ANA(QTQZ0100) +
DSN.DBXDP4G.AOPT(QTQZ0100) +
DSN.DBXDP4G.ANA(QTQZ0100) +
DSN.DBXDP4G.QUICK(QTQZ0100)
end
if 0 then do
call readDsn 'A540769.WK.TEXT(ANAPOBF2)', tt.
do tx=440 to tt.0
say '***' tx '***' strip(tt.tx) '************'
parse var tt.tx fun dbSy mbr inDsn .
drop m.
call ini
call workFun fun, dbSy, mbr, inDsn, , 0,
, overlay('Q', inDsn, 24)
if 0 then do
call dbAllOut inA
say err 'tstEnd1' ; exit
end
end
say err 'tstEnd2' ; exit
end
if 0 then do
call workMain 'ARC A540769.tmp.##DT##.EXE'
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'CD030341', 'A540769.TMP.TEXT(CD030341)',
, 'A540769.tmp.text(cd03aop1)',
, 0, 'A540769.TMP.TEXT(ANAPOST)' ,
, 'A540769.TMP.TEXT(ANAQUICK)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'QTM2UTS9', 'DSN.DBXDP4G.AN1(QTM2UTS9)' ,
, 'DSN.DBXDP4G.aopt(QTM2UTS9)',
, 0, 'A540769.TMP.TEXT(ANAPOST)' ,
, 'A540769.TMP.TEXT(ANAQUICK)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'DDL', 'DP4G', 'QTM2UTSV' ,
, 'DSN.DBX.DDK(QTM2UTS6)' ,
, , 0, 'A540769.TMP.TEXT(QTM2UTS6)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'QTM2UTST',
, 'DSN.DBxDP4G.an1(qtm2utsT)' ,
, 'DSN.DBXDP4G.aopt(QTM2UTST)' ,
, 0, 'A540769.TMP.TEXT(ANAPOST)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
/* m.fTst = '2015-01-01-12:30:00' */
call workFun 'REC', , 'TT010331', 'DSN.DBXDE0G.RE1(TT010331)' ,
, 'A540769.TMP.TEXT(AOPT)' ,
, 0, 'A540769.TMP.TEXT(ANAPOREC)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'PRE', ,'QTM2UTS6', 'DSN.DBX.DDL(QTM2UTS6)' ,
, 'A540769.TMP.TEXT(AOPT)' ,
, 1, 'A540769.TMP.TEXT(ANAPRE)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call genPre 'DSN.DBXDP4G.ANA(CMN001Y)',
, 'A540769.TMP.TEXT(ANAPRE)'
call anaAna aa, 'DSN.DBXDP4G.ANA(WK401010)'
call anaAna aa, 'DSN.DBX.DDL(AGNEST10)'
call anaAna aa, 'DSN.DBX.DDL(WK40105W)'
call err 'tstEnd'
a = 'ANA A540769.TMP.LCTL(DROP1)' Tst
a = 'EXE DSN.DBXDBOF.EXE(TG010231)'
a = 'REC DSN.DBXDBAF.REC(WK40300T) OF WK40300T 130130:113528.6'
a = 'ANA DSN.DBXDP4G.ANA(WK401031)'
exit workMain(a)
end
exit err('never pass here')
/* driver and initialisation *****************************************/
/*--- select work depending on main arguments -----------------------*/
workMain: procedure expose m.
parse upper arg fun dbSys ddl w4 w5 w6 w7 w8 w9
if \ abbrev(dbSys, 'D') | length(dbSys) <> 4 then do
parse upper arg fun ddl w4 w5 w6 w7
dbSys = substr(ddl, 8, 4)
end
mbr = dsnGetMbr(ddl)
if length(mbr) \== 8 & fun \== 'ARC' then
call err 'bad member in ddl' ddl
if fun == 'ANA' & w4 == '' then /* old syntax for ana */
return workFun(fun, dbSys, mbr, ddl, , 1, ddl)
else if fun == 'ANA' & w6 \== '' & w7 = '' then /* new ana */
return workFun(fun, dbSys, mbr, ddl, w4, 1, w5, w6)
else if fun == 'ARC' then
return archive(dbSys, ddl w4 w5 w6 w7)
else if fun == 'DDL' & w4 \== '' & w5 == '' then
return workFun(fun, dbSys, mbr, ddl, , 0, w4)
else if fun == 'PRE' & w5 \== '' & w6 == '' then
return workFun(fun, dbSys, mbr, ddl, w4, 1, w5)
else if fun == 'REC' & w4 == 'OF' & w6 \== '' & wR = '' then do
m.fTst = tst2db2(w6, 'bad anaTimestamp' fTst 'in args' arg(1))
if w5 <> mbr then
call err 'of' w5 'mismatches mbr='mbr
return workFun(fun, dbSys, mbr, ddl, , 1, ddl)
end
else if fun == 'REC' & w5 == 'OF' & w7 \== '' & w8 = '' then do
m.fTst = tst2db2(w7, 'bad anaTimestamp' w8 'in args' arg(1))
if w6 <> mbr then
call err 'of' w6 'mismatches mbr='mbr
return workFun(fun, dbSys, mbr, ddl, , 1, w4)
end
else if fun == 'EXE' then do /* old exe */
call readDsn 'dd(EXE)', e.
call writeDsn ddl '::f', e., ,1
exit 0
end
else
call err "implement fun: '"arg(1)"'"
endProcedure workMain
workFun: procedure expose m.
parse arg m.inA.Fun, m.inA.dbSys, m.inA.mbr, m.inA.inDsn, m.inA.optDsn,
, doArc, m.inA.OutDsn, m.inA.quickDsn
fn = m.inA.fun
call aOptRead inOpt, m.inA.optDsn
m.chOpt.0 = 0
b = jBuf()
m.inA.buf = b
call readDsn m.inA.inDsn, 'M.' || b'.BUF.'
say m.b.buf.0 'records in' m.inA.inDsn
if doArc & m.inA.inDsn == m.inA.outDsn then do
cy = pos('(', m.inA.inDsn) - 1
if cy <= 0 then
call err 'bad inDsn' m.inA.inDsn
else if substr(m.inA.inDsn, cy, 1) == 1 then
call err 'llq ends already with 1 in inDsn' m.inA.inDsn
m.inA.inDsn = overlay(1, m.inA.inDsn, cy)
call writeDsn m.inA.inDsn, 'M.' || b'.BUF.', , 1
arc = 1
end
if m.b.buf.0 < 1 then
call err 'empty analysis' m.inA.inDsn
call AnaAna inA, b
if fn = 'ANA' then
aDb = m.inA.straTrg
else if fn = 'REC' then
aDb = m.inA.straSrc
else
aDb = ''
if aDb \== '' & \ (length(aDb) == 4 & abbrev(aDb, 'D')) then
call err 'bad src/trg ssid in ana:' aDb
if m.inA.dbSys = '' then
m.inA.dbSys = aDb
if m.inA.dbSys = '' then
call err 'no dbSys in args or ana'
else if aDb \== '' & m.inA.dbSys \== aDb then
call err 'strategy src/trg='aDb ,
'mismatches argument dbSys='m.inA.dbSys
if m.inA.conStra \== '' & m.inA.conStra \== m.inA.straCrNm then
call err 'control='m.inA.conStra 'mismatches ana='m.inA.straCrNm
if m.inA.stra \== m.inA.mbr ,
& wordPos(m.inA.stra,'QUICKM RECOVERY') < 1 then
if fn == 'PRE' then
say 'strategy' m.inA.straCrNm 'mismatches' m.inA.inDsn
else
call err 'strategy' m.inA.straCrNm 'mismatches' m.inA.inDsn
cSnap = 0
do ax=1 to m.inA.0
if m.inA.ax.verb = 'AnaPosHea' then
if m.inA.ax.obj \== 'DDL' then
call err 'anaPost' m.inA.ax.obj 'already run'
if m.inA.ax.verb = 'bp.CALL' & m.inA.ax.obj = 'SNAPSHOT' then
cSnap = cSnap + 1
end
if cSnap <> (fn == 'ANA') then
say 'warning fun' fn 'but' cSnap 'snapshots'
m.outA.0 = 0
if fn == 'DDL' then do
call genDdl inA, outA
call writeDsn m.inA.outDsn '::f', 'M.OUTA.', , 1
return 0
end
call sqlConnect m.inA.dbSys
call ddlAddParents
if fn == 'PRE' then /* control */
call genPre inA, outA
else do
if fn = 'ANA' then do
if m.inA.conStra == '' then
call err 'no .control in ana'
if m.inOpt.0 > 2 then
if m.inA.noUnload ,
\== ( wordPos('DDLONLY', m.inOpt.opts) > 0) then
call err 'noUnloads but not ddlOnly'
end
else if fn == 'REC' then do
if m.inA.stra \== 'RECOVERY' then
call err 'not a recovery strategy'
end
else
call err 'bad fun' fn
call genPost inA, outA
end
if doArc then do
call archive m.inA.dbSys, m.inA.inDsn, b'.BUF'
call archive m.inA.dbSys, m.inA.outDsn, outA
end
call aOptWrite inOpt, chOpt
call writeDsn m.inA.outDsn '::f', 'M.OUTA.', , 1
call sqlDisconnect
if m.ina.quickDsn \== '' then do
m.quO.0 = 0
call genQUICK quO
call writeDsn m.inA.quickDsn '::f', 'M.QUO.', , 1
end
return 0
endProcedure workFun
ini: procedure expose m.
call errReset 'hi'
call sqlIni
call scanWinIni
call jIni
m.lastSync = 0
qq = date('j') (date('s') time())
m.myJul = word(qq, 1)
m.myTst = tst2db2(subWord(qq, 2))
m.clANode = classNew('n ANode u f VERB v, f OBJ r, f SUB s o',
',f FR v, f TO v')
m.clAON = classNew('n AON u f ATT v, f OLD v, f NEW v')
m.ddl_Types.index = 'IX'
m.ddl_Types.table = 'TB'
m.ddl_Types.tableSpace = 'TS'
m.ddl_Types.view = 'VW'
m.ddl.ix.0 = 0
m.ddl.tb.0 = 0
m.ddl.ts.0 = 0
m.ddl_Types = 'IX TB TS'
m.clDDL = classNew('n Ddl u f QUAL v, f NAME v, f TYPE v' ,
', f PAR r, f PAROLD r, f ACD v, f FUN v' ,
', f ANO s ANode, f ALT s AON')
m.clDdl.ix = classNew('n DdlIx u Ddl, f DBSP v, f PIECESIZE v')
m.clDdl.tb = classNew('n DdlTb u Ddl, f PARTBYSZ v')
m.clDdl.ts = classNew('n DdlTs u Ddl, f DSSIZE v, f SEGSIZE v',
', f NUMPARTS v, f MAXPARTITIONS v, f FREEPAGE v, f MAXROWS v')
m.clDdl.vw = classNew('n DdlVw u Ddl, f FRJO s v')
return
endProcedure ini
tst2db2: procedure expose m.
parse arg i, eMsg
t = 'yz34-56-78-hi.mn.st'
t3 = '34-56-78-hi.mn.st'
j = translate(i, '999999999', '012345678')
if abbrev('999999:999999.9', j, 7) then
return '20'translate(t3'.a' ,
, i || substr('000000.0', length(i)-6), '345678:himnst.a')
else if abbrev('9999-99-99-99.99.99.9999999999', j, 19) then
return i
else if j == '99999999 99:99:99' then
return translate(t, i, 'yz345678 hi:mn:st')
else if j == '99/99/99 99:99' then
return '20'translate(left(t3, 14), i, '56/78/34 hi:mn')'.00'
else if eMsg == '-' then
return '-'
else if eMsg == '' then
call err 'bad timestamp' i
else
call err eMsg
endProcedure tst2db2
/* generate modified analysis ****************************************/
/*--- ddl: modify DDL: dsSize for PBG etc. --------------------------*/
genDDL: procedure expose m.
parse arg aa, oo
say time() strip(sysvar('syscpu')) 'genDDl begin'
call ddlAltPartBySz
do tx=1 to m.ddl.ts.0
t1 = 'DDL.TS.'tx
if m.t1.maxpartitions > 0 & m.t1.dsSize <> '4G' then do
m.t1.fun = 'a'
call ddlAddAlt t1, dsSize, m.t1.dsSize, '4G'
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
laTo = m.aa.1.to
call genChkStart oo, aa, 'DDL', chOpt
do ax=2 to m.aa.0
if wordPos(m.aa.ax.verb, 'CREATE ALTER') > 0 then
laTo = genAlter(oo, b, laTo, aa'.'ax, new)
end
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return 0
endProcedure genDDL
/*--- preAnalysis: modify DDL to avoid drop/recreate etc. -----------*/
genPre: procedure expose m.
parse arg aa, oo
uts2old = 0
/* call ddlAltPartBySz no| changes from new to old| */
do tx=1 to m.ddl.ts.0
t1 = 'DDL.TS.'tx
m.t1.newUts = m.t1.maxPartitions > 0 ,
| (m.t1.segSize > 0 & m.t1.numParts > 0 )
if sql2one("select dbName, name, partitions, maxPartitions" ,
", segSize, dsSize, type, maxRows" ,
", (select max(freePage) from sysibm.sysTablePart p",
"where p.dbName=s.dbName and p.tsName=s.name) freePg",
'from sysibm.sysTablespace s' ,
"where dbName='"m.t1.qual"' and name = '"m.t1.name"'",
,tc , , ,'--') == '-' then do
say t1 m.t1.qual'.'m.t1.name 'not found in' m.aa.dbSys
m.t1.oldUts = 0
end
else do /* attention sometime trailing spaces in catalog */
if m.t1.name <> m.tc.name | m.t1.qual <> m.tc.dbName then
call err 'sql mismatch' o2Text(t1)
m.t1.oldUts = m.tc.type == 'G' | m.tc.type == 'R'
if m.t1.newUts & \ m.t1.oldUts then
m.t1.fun = 'ae' /* old --> UTS */
else if m.t1.newUts & m.t1.oldUts ,
& ( m.tc.segSize <> m.t1.segsize ,
| ddlFilter(dsSize, m.tc.dsSize) ,
<> ddlFilter(dsSize, m.t1.dsSize) ,
| ddlFilter(maxRows, m.tc.maxRows) ,
<> ddlFilter(maxRows, m.t1.maxRows )) then
m.t1.fun = 'ae' /* attribute change of UTS */
else if \ m.t1.newUts & m.t1.oldUts then do
uts2old = uts2old + 1
say '||| ts' m.t1.qual'.'m.t1.name ,
'from UTS to nonUTS'
end
end
if m.t1.fun == '' then
iterate
call mAdd chOpt, 'ts' m.t1.fun m.t1.qual'.'m.t1.name
aForce = m.t1.newUts & \ m.t1.oldUts
if pos('a', m.t1.fun) < 1 then
iterate
call ddlAddAlt t1, maxPartitions, m.tc.maxPartitions,
, m.t1.maxPartitions
call ddlAddAlt t1, segSize, m.tc.segsize, m.t1.segsize, aForce
call ddlAddAlt t1, dsSize , m.tc.dsSize, m.t1.dsSize, aForce
call ddlAddAlt t1, maxRows, m.tc.maxRows, m.t1.maxRows
call ddlAddAlt t1, freePage,
, max(77, m.tc.freePg+11, m.t1.freePage+11), m.t1.freePage
end
if uts2old > 0 then do
say '|||' uts2old 'tablespaces from UTS to nonUTS'
if wordPos('UTS2OLD', m.inOpt.opts) > 0 then do
say '-> allowed because of option "uts2old 1" in Auftrag'
end
else do
say '-> to allow it, set option "uts2old 1" in Auftrag'
call err uts2old 'tablespaces from UTS to nonUTS'
end
end
do xx=1 to m.ddl.ix.0
x1 = 'DDL.IX.'xx
t1 = ddlPar(ddlPar(x1))
if t1 == '' | pos('a', m.t1.fun) < 1 then
iterate
pp = m.x1.piecesize
if pp \== '' & m.t1.newUts & \ m.t1.oldUts then
if translate(right(pp, 1)) == 'G' ,
& strip(left(pp, length(pp) - 1)) > 2 then do
/* piecesize invalid before alter to UTS| */
m.x1.fun = 'ae'
call mAdd chOpt, 'ix' m.x1.fun m.x1.qual'.'m.x1.name
call ddlAddAlt x1, piecesize, '2G', pp
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
laTo = m.aa.1.to
call genChkStart oo, aa, 'PRE', chOpt
do ax=2 to m.aa.0
if wordPos(m.aa.ax.verb, 'CREATE ALTER') > 0 then
laTo = genAlter(oo, b, laTo, aa'.'ax, old)
end
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return
endProcedure genPre
/*--- postAnalysis: modify Analysis revert change from genPre ... ---*/
genPost: procedure expose m.
parse arg aa, oo
say time() strip(sysvar('syscpu')) 'genPost begin'
aFu = m.aa.fun
o1 = '?'
call ddlGenAcd
call ddlAltPartBySz
if aFu = 'ANA' then do
/* copy alters from aOpt to m.ts...alt.* */
do ix=m.inOpt.preBegin+1 to m.inOpt.0 ,
while abbrev(m.inOpt.ix, ' ')
parse var m.inOpt.ix w1 w2 w3 w4 .
if \ abbrev(m.inOpt.ix, ' ') then do
u1 = translate(w1)
call mAdd chOpt, substr(m.inOpt.ix, 5)
o1 = '?'
if wordPos(w1, 'ix ts') < 1 then
call err 'not ix or ts in aOpt' ix':' m.inOpt.ix
else do
if symbol('M.ddl.u1.w3') == 'VAR' then do
o1 = m.ddl.u1.w3
m.o1.fun = w2
if w3 \== m.o1.qual'.'m.o1.name then
call err 'mismatch aOpt' ix':' m.inOpt.ix
end
else if w1 <> 'ix' then
call err w1 w3 'from aOpt missing in ana',
ix':' m.inOpt.ix
end
end
else do
if w3 \== '->' then
call err '-> missing in aOpt' ix':' m.inOpt.ix
if o1 \== '?' then
call ddlAddAlt o1, w1, w2, w4
else
call mAdd chOpt, substr(m.inOpt.ix, 5)
end
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
call genChkStart oo, aa, aFu, chOpt
do ddlAfterX = m.aa.0 by -1 to 2 while wordPos(m.aa.ddlAfterX.verb,
, 'ALTER CREATE DROP') < 1
end
if ddlAfterX = 1 then
say 'warning no DDL changes in analysis'
ddlAfterX = ddlAfterX + 1
ddlAfterX = ddlAfterX + (m.aa.ddlAfterX.verb == 'bp.SYNC')
if ddlAfterX > m.aa.0 then
call err 'ddlAFterX='ddlAFterX '>' m.aa.0'=m.'aa'.0'
genAlterEnd = 0
say time() strip(sysvar('syscpu')) 'genPost selRebi before'
call selRebiPkgs aa
say time() strip(sysvar('syscpu')) 'genPost selRebi after'
toEnd = ''
do ax=2 to m.aa.0
if ax == ddlAfterX then do
genAlterEnd = genAlterEnd + 1
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
if toEnd <> '' then
call genAlterEnd oo, b, toEnd
end
o = m.aa.ax.obj
if m.aa.ax.verb == 'bp.SYNC' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
call genSync oo, b, aa'.'ax
laTo = m.aa.ax.to
end
else if m.aa.ax.verb = 'bp.CALL' then do
if m.aa.ax.obj = 'SNAPSHOT' then do
ax = genSnapshot(aa, ax, oo, b, laTo)
laTo = m.aa.ax.to
end
else if anaIsRebind(aa, ax) then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = genRebind(oo, b, aa, ax)
laTo = m.aa.ax.to
end
end
else if m.aa.ax.verb == 'ALTER' & pos('e', m.o.fun) > 0 then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = ax + 1
ax = ax - (m.aa.ax.verb \== 'bp.SYNC')
laTo = m.aa.ax.to
if wordPos(o, toEnd) < 1 then
toEnd = toEnd o
end
else if m.aa.ax.verb == 'ALTER' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = genAlterMergePart(0, aa, ax, oo, b, new)
laTo = m.aa.ax.to
end
else if m.aa.ax.verb == 'CREATE' then do
laTo = genAlter(oo,b,laTo, aa'.'ax, new)
end
else if m.aa.ax.verb == 'DROP' then do
aO = m.aa.ax.obj
if pos(m.aO.type, 'TB TS') > 0 then
laTo = genDrop(oo, b, laTo, aa, ax)
end
else if abbrev(m.aa.ax.verb, 'md.') then do
isUL = wordPos(substr(m.aa.ax.verb ,
, lastPos('.', m.aa.ax.Verb)), '.UNLOAD .FUNLD') > 0
do sx=1 to m.aa.ax.sub.0
s1 = aa'.'ax'.SUB.'sx
if m.s1.verb == 'cont' then do
ll = m.s1.obj
laTo = genAdd(oo, b, laTo, m.s1.fr)
call genAdd1 oo, 1, left(ll, 72)
do lx=73 by 68 to length(ll)
call genAdd1 oo, 1, '--++'substr(ll, lx, 68)
end
laTo = m.s1.to
end
else if m.s1.verb == 'bp.SYNC' then do
laTo = genAdd(oo, b, laTo, m.s1.fr)
call genSync oo, b, s1
laTo = m.s1.to
end
else if isUl & m.s1.verb == 'bp.DATA' then do
do sy=1 to m.s1.sub.0
s2 = s1'.SUB.'sy
if m.s2.verb == 'bp.lobCols' then do
laTo = genAdd(oo, b, laTo, m.s2.to)
call genLobCols oo, aa'.'ax, s2
end
end
end
end
end
end
if genAlterEnd \== 1 then
call err 'genAlterEnd' genAlterEnd 'times'
ax = m.aa.0
laTo = genAdd(oo, b, laTo, m.aa.ax.to)
call genRebindAddMiss oo, aa
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return
endProcedure genPost
archive: procedure expose m.
parse arg dbSys, dsn, st
if st \== '' & words(dsn) \== 1 then
call err 'archive('dsn',' st') incompatible'
dt = 'D'translate(345678, left(m.myTst ,10), '1234-56-78'),
|| '.T'translate(123456, substr(m.myTst, 12, 8),'12.34.56')
do dx=1 to words(dsn)
d1 = word(dsn, dx)
mbr = dsnGetMbr(d1)
llq = substr(d1, lastPos('.', d1) + 1)
cx = pos('.##DT##.', d1)
if cx <= 0 then do
if mbr = '' then
call err 'archive' d1 'without member'
llq = left(llq, pos('(', llq) - 1)
oDsn = 'DSN.DBY'dbSys'.'mbr'.'dt'.'llq ,
'::f mgmtClas(com#a049)'
if st == '' then do
call readDsn d1, i.
call writeDsn oDsn, i., , 1
end
else do
call writeDsn oDsn, 'M.'st'.', , 1
end
end
else do
if mbr <> '' | cx + 7 + length(llq) <> length(d1) then
call err 'archive' d1 'with member'
dN = left(d1, cx)dt'.'llq
ar = adrTso("rename '"d1"' '"dN"'", '*')
if ar = 0 then
say 'renamed' d1 'to' dN
else if pos('NOT IN CATALOG', m.tso_trap) > 0 then
say d1 'not in catalog, not renamed'
else
call err 'could not rename' d1 'to' dN'\n'm.tso_trap
end
end
return 0
endProcedure archive
genQuick: procedure expose m.
parse arg out
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
if wordPos(t1, 'DATABASE FUNCTION IX' ,
'PROCEDURE TB TRIGGER TS VW') < 1 then
iterate
do dy=1 to m.d1.0
o = d1'.'dy
v = m.o.acd
/* if pos('d', v) >0 | (pos('a', v) >0 & pos('c', v) <1) then
rv162 is fixed, we can generate also dropped objs | */
call rcmQuickAdd out, m.o.type, m.o.qual, m.o.name
end
end
return
endProcedure genQuick
genRebind: procedure expose m.
parse arg o, b, aa, ax
ay = ax+1
az = aa'.'ay'.SUB.1'
rb = m.az.verb
if \ anaIsRebind(aa, ax) | \ abbrev(rb, 'rebind.') then
call err 'not a rebind' aa ax m.aa.ax.verb m.az.verb
k = m.az.obj
p = selPkgOne(k)
if \ abbrev(p, '-') then
if \ ( (rb == 'rebind.pkg' & pos(m.p.type, ' F') > 0) ,
| (rb == 'rebind.tri' & m.p.type == 'T') ) then
call err rb 'but pkg type='m.p.type 'for' k
if m.p.doRb == 'no' then do
if abbrev(p, '-') then
call genAddCont o, '--noRebind' substr(p, 2) k
else
call genAddCont o, '--noRebind necessary' m.p.vot k
do aq=ay+1 while m.aa.aq.verb == 'bp.SYNC'
end
return aq-1
end
if wordPos(m.p.doRb, 'last creT new7') > 0 then do
if m.p.missing then do
r = '--rebindMiss' m.p.doRb m.p.vot k 'in anaPost'
say r
call genAddCont o, r
end
call genAdd o, b, m.aa.ax.fr, m.aa.ax.to
m.p.gen = 1
return ax
end
else
call err 'bad doRb='m.p.doRb 'for pkg' k
endProcedure genRebind
genRebindAddMiss: procedure expose m.
parse arg o, aa
do px=1 to m.rebi.0
p = 'REBI.'px
if m.p.gen == 1 | m.p.doRb == 'no' then
iterate
k = strip(m.p.collid)'.'strip(m.p.name) ,
|| ':'strip(m.p.version)
if m.p.gen == 2 then
call err 'duplicate pkg' k
m.p.gen = 2
call genAddCont o,'--rebindAdd' m.p.doRb m.p.vot k 'by anaPost'
call mAdd o, '-- cre='m.p.timestamp 'las='m.p.lastUsed ,
, '.CALL DSN PARM('m.aa.dbSys')' ,
, '.DATA'
if pos(m.p.type, ' F') > 0 then
call mAdd o, ' REBIND PACKAGE( -' ,
, ' ' strip(m.p.collid)'.'strip(m.p.name) ,
|| '.('strip(m.p.version)'))'
else if m.p.type == 'T' then
call mAdd o, ' REBIND TRIGGER PACKAGE( -' ,
, ' ' strip(m.p.collid)'.'strip(m.p.name)')'
else
call err 'implement rebind type='m.p.type 'for' k
call mAdd o, '.ENDDATA '
call genSyncTx o, ".SYNC ? 'REBIND PACKAGE'"
call mAdd o, ' '
end
return
endProcedure genRebindAddMiss
/*--- find all packages to rebind
from list of ddl objects, after parOld is added to ix --------*/
selRebiPkgs: procedure expose m.
parse arg aa
cr.0 = 0 /* group the dependencies by creator */
m.rebiM0 = 0
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
do dy=1 to m.d1.0
o = d1'.'dy
if t1 == 'IX' then do /* rebind everybody using table */
if m.o.parOld == '' then do
/* for test only, try to guess name of dropped table ?????? */
n = 'T'substr(m.o.name, 2, length(m.o.name)-3)'A1'
m.o.parOld = ddlGetNew('TB', m.o.qual, n)
end
if m.o.par \== '' then
call selRebiPkgAdd m.o.par
if m.o.parOld \== '' & m.o.par \== m.o.parOld then
call selRebiPkgAdd m.o.parOld
end
else if t1 == 'TRIGGER' ,
| ( wordPos(t1, 'FUNCTION PROCEDURE TB TS VW') > 0 ,
& pos(m.o.acd, ' d,a d, ') <= 0) then
/* everything that is not dropped without recreate
really new objects are not in packDep yet */
call selRebiPkgAdd o
end
end
/* build the where condition for sysPackDep */
bTy.ALIAS = "bType = '0'"
bTy.FUNCTION = "bType = 'F'"
bTy.IX = "bType = 'I'"
bTy.PROCEDURE = "bType = 'O'"
bTy.TB = "bType in ('G', 'M', 'T')"
bTy.TRIGGER = "bType = 'E'"
bTy.TS = "bType in ('P', 'R')"
bTy.VW = "bType = 'V'"
sDep = "union all select dLocation, dCollid, dName, dContoken" ,
"from sysibm.syspackdep" ,
"where dType not in ('O', 'P')"
s = ''
do cx = 1 to cr.0
c1 = cr.cx
s2 = ''
s3 = ''
do cy=1 to words(cr.c1)
t2 = word(cr.c1, cy)
s2 = s2 || cr.c1.t2
s3 = s3 "or (bName in ("substr(cr.c1.t2,3)") and" bTy.t2")"
end
s = s sDep "and bqualifier = '"c1"' and bName in" ,
"("substr(s2, 3)") and (" substr(s3, 4) ")"
end
if s = '' then do
say 'no objects found that may have package dependencies'
m.rebi.0 = 0
return
end
say '???packSel' s
m.packDepSql = "select p.collid, p.name, p.version, p.type" ,
", p.valid || p.operative || p.type vot" ,
", p.contoken, p.timestamp, p.timestamp, p.lastUsed" ,
", case when lastUsed>current date-10 days then 'last'",
"when timestamp>current timestamp-7 days then 'creT'",
"when not exists (select 1" ,
"from sysibm.syspackage r" ,
"where r.location=p.location and r.collid=p.collid",
"and r.name = p.name" ,
"and r.timestamp > p.timestamp" ,
"and r.timestamp <= current timestamp - 7 days)",
"then 'new7' else 'no' end doRb",
"from sysibm.sysPackage p"
sql = "with d1 as (" substr(s, 11) ")" ,
", d as ( select dLocation, dCollid, dName, dContoken" ,
"from d1",
"group by dLocation, dCollid, dName, dContoken )",
m.packDepSql "join d" ,
"on dLocation = location and dCollid = collid",
"and dName = name and dConToken = conToken"
call sql2St sql, rebi
/* the index to packages to rebind
and count pkg by reasons not to bind */
do rx=1 to m.rebi.0
m.rebi.rx.missing = 0
k = strip(m.rebi.rx.collid)'.'strip(m.rebi.rx.name) ,
|| ':'strip(m.rebi.rx.version)
dr = m.rebi.rx.doRb
cL = 'last creT new7 no'
if symbol('c.dr') == VAR then
c.dr = c.dr + 1
else do
c.dr = 1
if wordPos(dr, cL) < 1 then
cL = cL dr
end
/*say k m.rebi.rx.doRb m.rebi.rx.vot */
m.rebi.k = 'REBI.'rx
end
cM = m.rebi.0 'dependent packages'
do cx=1 to words(cL)
c1 = word(cL, cx)
if symbol('c.c1') == 'VAR' then
cM = cM',' c.c1 c1
end
say cM
return
endProcedure selRebiPkgs
/*--- add one dependency, grouped by creator ------------------------*/
selRebiPkgAdd: procedure expose m. cr.
parse arg o
q = m.o.qual
n = m.o.name
t = m.o.type
if q = '' | n = '' then
call err 'empty qual or name' o2Text(o)
if cr.t.q.n == 1 then
return
if symbol('cr.q') \== 'VAR' then do
cr.q = ''
cx = cr.0 + 1
cr.0 = cx
cr.cx = q
end
if symbol('cr.q.t') \== 'VAR' then do
cr.q = cr.q t
cr.q.t = ''
end
cr.q.t = cr.q.t", '"n"'"
cr.t.q.n = 1
return
endProcedure selRebiPkgAdd
/*--- return pkg info, select for sysPack if not already done -------*/
selPkgOne: procedure expose m.
parse arg k
if symbol('m.rebi.k') == 'VAR' then
return m.rebi.k
parse arg co '.' pk ':' ve
if symbol('m.rebiCoPk.co.pk') == 'VAR' then do
r = '-not in sysPackage'
m.r.doRb = 'no'
return r
end
say 'selecting missing package' co'.'pk
m.rebiCoPk.co.pk = 1
m.rebiM0 = m.rebiM0 + 1
rm = 'REBIM'm.rebiM0
sql = m.packDepSql "where location ='' and collid = '"co"'" ,
"and name = '"pk"'"
call sql2St sql, rm
do rx=1 to m.rm.0
km = strip(m.rm.rx.collid)'.'strip(m.rm.rx.name) ,
|| ':'strip(m.rm.rx.version)
if symbol('m.rebi.km') == 'VAR' then
iterate
m.rebi.km = rm'.'rx
m.rm.rx.missing = 1
end
return selPkgOne(k)
endProcedure selPkgOne
genChkStart: procedure expose m.
parse arg o, m, fun, ch
call mAdd o, '--## anaPost modifying analysis' m.myTst ,
, '--## dbSys =' m.m.dbSys ,
, '--## fun =' fun ,
, '--## in =' m.m.inDsn ,
, '--## ' m.m.straCrNm m.m.anaTst,
, '--## out =' m.m.outDsn
if fun = 'PRE' & m.ch.0 > 0 then
call mAdd o, '--##* overwriting new values from ddl' ,
, '--##* by old values from' m.m.dbSys ,
, '--##* attribute old -> new',
, '--##*'
if fun = 'ANA' & m.ch.0 > 0 then
call mAdd o, '--##* overwriting old values from' m.m.dbSys ,
, '--##* by new values from ddl' ,
, '--##* attribute old -> new',
, '--##*'
if wordPos(fun, 'PRE ANA') > 0 then
do ix=1 to m.ch.0
call mAdd o, '--## ' m.ch.ix
end
if fun = 'REC' then
call mAdd o, '--## recovery =' m.m.straCrNm m.m.anaTst,
, '--## of' m.m.mbr m.fTst ,
, '.CONNECT' m.m.dbSys ,
, '||||Achtung |||||||||||||||||||||||||||||||||||||||',
, ' diese Recovery Analyse darf nicht so laufen; ',
, ' wie sie hier generiert ist| ',
, ' recovery unloads sind zu ueberpruefen ; ',
, ' und/oder nur als ddl vorlage zu benutzen ; ',
, ' ; abend ; abend; abend; abend; abend; ',
, '|||||||||||||||||||||||||||||||||||||||||||||||||||',
, '.DISCONN'
m.lastSync = 3
if fun = 'PRE' | fun = 'DDL' then
return
call madd o, '--##begin chkstart: avoid duplicate runs' ,
, '.CALL IKJEFT01 INDDN(SYSTSIN) OUTDDN(SYSTSPRT)' ,
'SYSLIB NONAPF' ,
, ' .DATA' ,
, ' %chkStart dbSys='m.m.dbSys '+' ,
, ' 'fun'='m.m.straCrNm m.m.anaTst '+'
if fun == 'ANA' then
call mAdd o, ' ddl='m.m.outDsn
else
call mAdd o, ' ddl='m.m.outDsn '+' ,
, ' of='m.m.mbr m.m.anaTst
call mAdd o, ' .ENDDATA' ,
, ".SYNC 3 'checkStart' " ,
, '--##end chkStart: avoid duplicate runs'
return
endProcedure genChkStart
genDrop: procedure expose m.
parse arg o, i, laTo, aa, ax
if m.aa.fun \== 'ANA' then
return laTo
dOb = m.aa.ax.obj
if m.dOb.type == 'TS' then do
dTs = dOb
dTb = ''
end
else if m.dOb.type == 'TB' then do
dTb = dOb
dTs = ddlPar(dOb)
end
ul = ''
if dTs \== '' then
ul = ddlGetUnl(dTs)
if ul == '' then
if dTb \== '' then
ul = ddlGetUnl(dTb)
else do tx=1 to m.ddl.tb.0 while ul = ''
if ddlPar('DDL.TB.'tx) == dTs then
ul = ddlGetUnl('DDL.TB.'tx)
end
nm = m.dOb.type m.dOb.qual'.'m.dOb.name
if ul == '' then do
if m.aa.noUnload then
say 'drop' nm 'not unloaded ok because noUnload'
else
call err 'drop' nm 'but no Unload'
return laTo
end
if \ posLess(m.ul.to, m.aa.ax.fr) then
call err 'drop' nm '@'m.aa.ax.fr 'before unload @'m.ul.to
ay = ax - 1
if ay < 1 | m.aa.ay.verb \== 'bp.SYNC' then
call err 'no syncPoint before drop' nm':' m.aa.ax.fr
ay = ax + 1
if ay > m.aa.0 | m.aa.ay.verb \== 'bp.SYNC' then
call err 'no syncPoint after drop' nm':' m.aa.ax.fr
call mAdd o,,left('--##begin anaPost -dis for' nm, 80) ,
, ' .CALL DSN PARM('m.aa.dbSys')' ,
, ' .DATA' ,
, ' -DIS DB('m.dTs.qual') SPACE('m.dTs.name')' ,
'LIMIT(*)' ,
, ' .ENDDATA' ,
, left('--##end anaPost -dis for' nm, 80) ,
, ''
if m.dOb.type \== 'TB' then
return laTo
laTo = genAdd(o, i, laTo, m.aa.ax.to)
call mAdd o,,left('--##begin anaPost -sta for' nm, 80) ,
, ' .CALL DSN PARM('m.aa.dbSys')' ,
, ' .DATA' ,
, ' -STA DB('m.dTs.qual') SPACE('m.dTs.name')' ,
'ACCESS(RW)' ,
, ' .ENDDATA' ,
, left('--##end anaPost -sta for' nm, 80) ,
, ''
return laTo
endProcedure genDrop
genSnapshot: procedure expose m.
parse arg aa, ax, o, i, laTo
ax = ax+1
if m.aa.ax.verb <> 'bp.ALLOC' ,
| \ abbrev(m.aa.ax.obj, 'FI(RCVRFILE)') then
call err '.ALLOC FI(RCVRFILE) expected after snapshot'
ix = 1 + word(m.aa.ax.fr, 1)
li = strip(m.i.ix)
qx = pos("'", li, 5)
if \ abbrev(li, "DA('") | qx < 5 then
call err "DA('...' expected after .alloc in snapshot"
rDs = substr(li, 5, qx-5)
if dsnGetMbr(rDs) <> m.aa.stra then
call err 'stra='m.aa.stra '<> member in rcvrfile' rds
ax = ax+1
if m.aa.ax.verb <> 'bp.DATA' then
call err '.DATA expected after snapshot'
ax = ax+1
if m.aa.ax.verb <> 'bp.FREE' | m.aa.ax.obj <> 'FI(RCVRFILE)' then
call err '.FREE expected after snapshot'
ax = ax+1
if m.aa.ax.verb <> 'bp.SYNC' then
call err '.SYNC expected after snapshot'
laTo = genAdd(o, i, laTo, m.aa.ax.fr)
call genSync o, i, aa'.'ax
cx = lastPos('.', rDs)
cy = pos('(', rDs, cx + 1)
if cx <= 0 | cy <= cx then
call err 'bad recovery dsn' rDs
oDs = left(rDs, cx)'REC'substr(rDs, cy)
call mAdd o,,'--##begin anaPost on snapshot analyse' ,
, '.CALL IKJEFT01 INDDN(SYSTSIN) OUTDDN(SYSTSPRT)' ,
'SYSLIB NONAPF' ,
, ' .DATA' ,
, ' %anaPost rec' m.aa.dbSys rDs '+' ,
, ' ' oDS '+' ,
, ' of' m.aa.stra m.aa.anaTst ,
, ' .ENDDATA' ,
, '--##end anaPost on snapshot analyse'
call genSyncTx o, ".SYNC ? 'anaPost of snapshot'"
return ax
endProdedure genSnapshot
genLobCols: procedure expose m.
parse arg o, mdl, lb
lobs = m.lb.obj
tb = m.mdl.obj
call sqlQuery 1, "select name, colType from sysibm.sysColumns",
"where tbCreator = '"m.tb.qual"' and tbName = '"m.tb.name"'" ,
"order by case when colType like '%LOB%'" ,
"or colType like '%XML%' then 1 else 0 end, colno"
lft = ' ('
do fx=1 while sqlFetch(1, f1)
call mAdd o, lft m.f1.name m.f1.colType
lft = ' ,'
end
if fx <= 1 then do
call mAdd o, '||| no cols |||||||'
call aOptErr 'post.noCols', 'no columns in' ,
m.tb.qual'.'m.tb.name
end
call mAdd o, ' )', ' SPANNED YES' , '--UNLOAD--LOBCOLS end'
call sqlClose 1
return ix
endProcedure genLobCols
genSyncTx: procedure expose m.
parse arg out, tx
tx = strip(tx)
parse var tx tV tN tT
if tV \== '.SYNC' then
call err 'bad syncpoint text' tx
if datatype(tn, 'n') & tn > m.lastSync then
m.lastSync = tn
else do
m.lastSync = m.lastSync + 1
tx = tV m.lastSync tT
end
tT = strip(tT)
if tT <> '' then
if \ (abbrev(tT, "'") & pos("'", tT, 2) = length(tT)) then
tx = subWord(tx, 1, 2) "'"strip(translate(tt, ' ', "'"))"'"
if length(tx) > 70 then do
tx = space(tx, 1)
if length(tx) > 70 then
tx = left(tx, 66)"...'"
end
call mAdd out, tx
return 0
endProcedure genSyncTx
genSync: procedure expose m.
parse arg out, in, an
ix = word(m.an.fr, 1)
if abbrev(m.in.ix, '--##.SYNC') then
return genSyncTx(out, substr(m.in.ix, 5))
else
return genSyncTx(out, m.in.ix)
endProcedure genSync
/*--- generate DDL with altered attributes, add semicolon -----------*/
genAlter: procedure expose m.
parse arg out, in, laTo, aNo, col, ign, rm
o = m.aNo.obj
if pos('a', m.o.fun) <= 0 then
return laTo
/* say m.o.type m.o.qual'.'m.o.name m.o.fun */
if m.aNo.sub.1.verb \== 'ddlHead' then
call err 'no ddlHead' o2text(aNo'.SUB.1') 'in' o2text(aNo)
head = aNo'.SUB.1'
if posLess(laTo, m.aNo.fr) then
laTo = genAdd(out, in, laTo, m.aNo.fr)
parse var m.aNo.to tL tC
if genAlterHd(out, in, head, aNo, col, ign, rm) then
call genAdd out, in, tL tC-1, tL tC
return tL tC
endProcedure genAlter
/*--- generate DDL with altered attributes, without semicolon
if create add missing altered attributes ---------------*/
genAlterHd: procedure expose m.
parse arg out, in, head, aNo, col, ign, rm
o = m.aNo.obj
/* say m.o.type m.o.qual'.'m.o.name m.o.fun */
done = 0
laTo = m.aNo.sub.1.to
part = ''
do sx = 2 to m.aNo.sub.0
s1 = aNo'.SUB.'sx
if laTo <> m.s1.fr then
call genAlterHdAddTo laTo, m.s1.fr
laTo = m.s1.to
v1 = substr(m.s1.verb, 4)
if m.s1.verb == 'part' then do
part = s1
end
else if \ abbrev(m.s1.verb, 'at.') | wordPos(v1, ign) > 0 ,
| symbol('m.o.alt.'v1) \== 'VAR' then do
call genAlterHdAddTO m.s1.fr, m.s1.to
end
else do
a1 = m.o.alt.v1
done.v1 = 1
if m.a1.col \== '-' & wordPos(v1, rm) < 1 then do
call genAlterHdAddTo
call genAdd1 out, 9, v1 m.a1.col
end
end
end
parse var m.aNo.to tL tC
if substr(m.in.tL, tC-1, 1) \== ';' then
call err ', expected at end of' o2text(aNo)
if laTo <> tL tc-1 then
call genAlterHdAddTo laTo, tL tC-1
if m.aNo.verb == 'CREATE' then do
do ax=1 to m.o.alt.0 /* add altered attributes */
a1 = o'.ALT.'ax
v1 = m.a1.att
if m.a1.col \== '-' & done.v1 \== 1 then do
call genAlterHdAddTO
call genAdd1 out, 9, v1 m.a1.col
end
end
end
return done
endProcedure genAlterHd
genAlterHdAddTo: /* add alter and partition part */
parse arg addFrX, addToX
if head \== '' then do
call genAdd out, in, m.head.fr, m.head.to
head = ''
end
if part \== '' then do
call genAdd out, in, m.part.fr, m.part.to
part = ''
end
if addFrX \== '' then
call genAdd out, in, addFrX, addToX
done = 1
return
endSubroutine genAlterHdAddTo
/*--- merge alter Parts and alter attributes
swallow syncpoints ----------------------------------------*/
genAlterMergePart: procedure expose m.
parse arg inDir, qq, qx, out, in, col ,ign, rm
aa = qq'.'qx
if inDir then
aa = m.aa
o1 = m.aa.obj
if m.aa.sub.1.verb \== 'ddlHead' then
call err 'no ddlHead' o2text(aa'.SUB.1') 'in' o2text(aa)
head = aa'.SUB.1'
if \ genAlterHd(out, in, head, aa, col, ign, rm) then
return qx
parse var m.aa.to toL toC
if substr(m.in.toL, toC-1, 1) \== ';' then
call err 'not ; at end of alter:' m.aa.to':' m.in.toL
if m.aa.verb \== 'ALTER' | m.aa.sub.1.verb \== 'ddlHead' ,
| m.aa.sub.2.verb \== 'part' then do
call genAdd out, in, toL toC-1, m.aa.to
return qx
end
do qx = qx+1 to m.qq.0
aa = qq'.'qx
if inDir then
aa = m.aa
if m.aa.verb = 'bp.SYNC' then
iterate
if m.aa.verb \== 'ALTER' | m.aa.sub.1.verb \== 'ddlHead' ,
| m.aa.sub.2.verb \== 'part' | m.aa.obj \== o1 then
leave
call genAlterHd out, in, , aa, col, ign, rm
end
call genAdd1 out, 6, ';'
qx = qx - 1
aa = qq'.'qx
if inDir then
aa = m.aa
return qx - (m.aa.verb = 'bp.SYNC')
endProcedure genAlterMergePart
/*--- append remaining alters ---------------------------------------*/
genAlterEnd: procedure expose m.
parse arg oo, b, toEnd
attEnd = 'MAXPARTITIONS SEGSIZE DSSIZE MAXROWS PIECESIZE'
/* segSize AFTER maxParts for migration to PGB| */
call mAdd oo, '----- moved alter TS to end of DDL ------'
do ox=1 to words(toEnd)
o = word(toEnd, ox)
done = 0
do vx=1 to m.o.aNo.0
v1 = m.o.aNo.vx
if m.v1.verb \== 'ALTER' then
iterate
vx = genAlterMergePart(1, o'.ANO', vx,
, oo, b, new, , attEnd)
done = 1
end
if done then
call genSyncTx oo, ".SYNC ? 'alter",
m.o.type m.o.qual'.'m.o.name"'"
done = 0
do wx=1 to words(attEnd)
w1 = word(attEnd, wx)
if symbol('m.o.alt.w1') == 'VAR' then do
a2 = m.o.alt.w1
n = m.a2.new
if n = '-' & w1 = maxRows then
n = 255
if n \== '-' then do
done = 1
if m.o.type = 'IX' then
call mAdd oo, '-- alter index',
m.o.qual'.'m.o.name ,
, '-- ' m.a2.att n';',
, '-- not allowed here'
else
call mAdd oo, ' alter tablespace',
m.o.qual'.'m.o.name ,
, ' ' m.a2.att n';'
end
end
end
if done then
call genSyncTx oo, ".SYNC ? 'alter",
m.o.type m.o.qual'.'m.o.name"'"
end
return
endProcedure genAlterEnd
/*--- add to o from i (fLi fCh) to i (tLi tCh) ----------------------*/
genAdd: procedure expose m.
parse arg o, i, fLi fCh, tLi tCh
if fLi >= tLi then do
if posLess(tLi tCh, fLi fCh) then
call err 'fr after to' fLi fCh',' tLi tCh
call genAdd1 o, fCh, substr(m.i.fLi, fCh, tCh-fCh)
end
else do
call genAdd1 o, fCh, substr(m.i.fLi, fCh)
ox = m.o.0
do ix = fLi + 1 to tLi - 1
ox = ox+1
m.o.ox = m.i.ix
end
if left(m.i.tLi, tCh-1) <> '' then do
ox = ox + 1
m.o.ox = left(m.i.tLi, tCh-1)
end
m.o.0 = ox
if ix <> tLi then
call err 'mismatch'
end
return tLi tCh
endProcedure genAdd
genAdd1: procedure expose m.
parse arg o, ch, tx
ox = m.o.0
if tx = '' then
return
else if ox < 1 then
ox = ox + 1
else if m.o.ox = '' then
nop
else if ch <= 1 then
ox = ox + 1
else if substr(m.o.ox, ch) <> '' then
ox = ox + 1
else if pos(substr(m.o.ox, ch-1, 1), ' ;+-*<>') < 1 ,
& pos(left(tx, 1), ' ;+ /<>') < 1 then
ox = ox + 1
else do
m.o.ox = left(m.o.ox, ch-1)tx
return
end
m.o.0 = ox
m.o.ox = left('', ch-1)tx
return
endProcedure genAdd1
genAddCont: procedure expose m.
parse arg o, tx
ox = m.o.0
ox = ox + (m.o.ox <> '')
if length(tx) <= 72 then do
m.o.ox = tx
end
else do
tx = strip(tx, 't')
if length(tx) <= 72 then
m.o.ox = tx
else if \ abbrev(strip(tx), '--') then
call err 'overflow in non comment:' tx
else do
m.o.ox = left(tx, 72)
do cx = 73 by 68 to length(tx)
ox = ox + 1
m.o.ox = '--++'substr(tx, cx, 68)
end
end
end
m.o.0 = ox
return
genAddCont
/*--- check no line in the stem is longer 72 ------------------------*/
checkL72: procedure expose m.
parse arg st
do sx=1 to m.st.0
if length(m.st.sx) > 72 then do
m.st.sx = strip(m.st.sx, 'T')
if length(m.st.sx) > 72 then
if \ (length(m.st.sx) <= 80,
& abbrev(strip(m.st.sx), '--')) then
call err 'line overflow' st'.'sx m.st.sx
end
end
return
endProcedure checkL72
/* analyse an analysis ***********************************************/
/*--- analyse an analysis ==> gen list of aNodes etc. ---------------*/
anaAna:procedure expose m.
parse arg m
sQ = scanOpen(scanSqlOpt(scanSqlReset(m'.SCSQL', m.m.buf, 72 22),
, m.ut_alfa'#@$'))
call jPosBefore m.m.buf, 1
sR = scanOpen(scanSqlOpt(scanSqlReset(m'.SCREA', m.m.buf '-', 0),
, m.ut_alfa'#@$'))
m.m.conStra = ''
m.m.stra = ''
m.m.straSrc = ''
m.m.straTrg = ''
m.m.noUnload = 0
ax = 1
a = aNodeClear(m'.'ax, 'head', , scanPos(sR))
do forever
if \ abbrev(m.sR.src, '--') then do
if scanLit(sR, '.CONTROL SN(') then do
if \ scanUntil(sR, ')') then
call scanErr sR, 'bad .control'
parse var m.sR.tok cr ',' st
if cr = '' | st = '' then
call scanErr sR, 'bad creator/name in .control'
if m.m.conStra \== '' then
call scanErr sR, 'duplicate .control'
m.m.conStra = strip(cr)'.'strip(st)
end
else if m.sR.src <> '' then
leave
call scanNl sR, 1
end
else if abbrev(m.sR.src, '--##') ,
| pos('*** END ANALYSIS HEADER **', t1) > 0 then do
leave
end
else if abbrev(m.sR.src, '-- RMA') then do
call anaRma m, sR
end
else do
if \ scanLit(sR, '--') then
call scanErr sR, 'bad header line'
call scanNl sR, 1
t1 = strip(m.sR.tok)
if abbrev(t1, 'RMA') then
call scanErr sR, 'RMA in header'
if pos('CA-DB2', t1) > 0 then do
cx = pos(' Analysis Report ', t1)
if cx < 0 then
call scanErr sR, 'Analysis Report missing'
m.m.RCMVers = word(t1, 1)
t2 = space(subWord(substr(t1, cx), 3, 4), 1)
m.m.anaTst = tst2db2(t2, '-')
if m.m.anaTst == '-' then
call scanErr sR, 'bad timestamp' t2
say 'RC/M vers='m.m.rcmVers 'anaTst='m.m.anaTst
end
else if abbrev(t1, 'Strategy ==> ') then do
m.m.stra = word(t1, 3)
cx = wordPos('Description', t1)
if cx <= 2 | word(t1, cx+1) \== '===>' then
call scanErr sR, 'strategy description expected'
m.m.straDesc = strip(subWord(t1, cx+2))
if \ (scanNl(sR, 1) ,
& abbrev(m.sR.tok, '--Creator ==> ') ) then
call scanErr sR, 'strategy creator expected'
m.m.straCrNm = word(m.sR.Tok, 3)'.'m.m.stra
cx = pos(' Src SSID ===> ', m.sR.Tok)
if cx < 1 then
call scanErr sR, 'strategy src ssid expected'
m.m.straSrc = word(substr(m.sR.Tok, cx + 15), 1)
say 'strategy='m.m.straCrNm ,
'srcSSID='m.m.straSrc 'desc='m.m.straDesc
end
else if abbrev(t1, 'Target SSID ') then do
if word(t1, 3) \=='===>' then
call scanErr sR, 'bad SSID'
m.m.straTrg = word(t1, 4)
end
end
end
do forever
if abbrev(m.sR.src, '-- RMA') then
call anaRMA m, sR
else if m.sR.src = '--' | m.sR.src = '' then
call scanNl sR, 1
else
leave
end
if m.m.stra = '' | m.m.straSrc m.straTrg = '' then
call scanErr sR, 'strategy header incomplete'
else if scanEnd(sR) then
call err 'end of file in header'
m.a.to = scanPos(sR)
ax = ax + 1
a = aNodeClear(m'.'ax)
do forever
r = 0
if scanSpaceOnly(sR) | scanNl(sR) then
iterate
if scanEnd(sR) then do
m.m.0 = ax - 1
return 1
end
m.a.fr = scanPos(sR)
if scanCom(sR) then do
if abbrev(m.sR.tok, '--##') then
r = anaModel(a, sR, m.sR.tok)
end
else if scanLook(sR, 1) == '.' then do
r = anaBP(m, ax, sR, 0)
end
else do
call scanSetPos sQ, m.a.fr
r = anaDdl(a, sQ)
call scanSetPos sR, scanPos(sQ)
end
if r then do
m.a.to = scanPos(sR)
ax = ax + 1
a = aNodeClear(m'.'ax)
end
end
endProcedure anaAna
anaRMA: procedure expose m.
parse arg m, s
if abbrev(m.s.src, '-- RMA233W NO UNLOADS') then
m.m.noUnload = 1
else if \ abbrev(m.s.src, '-- RMA') then
call scanErr s, 'not RMA'
say m.s.src
do while scanNl(s, 1) & abbrev(m.s.src, '-- ')
end
return
endProcedure anaRMA
/*--- analyze ca batchProcessor statement ---------------------------*/
anaBP: procedure expose m.
parse arg mm, mx, s, nst
m = mm'.'mx
call ANodeClear m, , ,scanPos(s)
call scanNl s, 1
parse var m.s.tok v r
upper v
m.m.verb = 'bp'v
m.m.obj = translate(strip(r))
if v \== '.DATA' then do
do while right(strip(m.s.tok), 1) == '+'
if \ scanNl(s, 1) then
call scanErr s, 'end in bp +' v
end
end
else do
my = mx-1
if m.mm.my.verb=='bp.CALL' & abbrev(m.mm.my.obj,'DSN PA') then
call anaBPRebind m, s
dx = m.m.sub.0 + 1
do forever
l1 = scanLook(s)
w1 = translate(word(l1, 1))
if \ abbrev(w1, '.') then do
if w1 == '--UNLOAD--LOBCOLS' ,
& l1 <> '--UNLOAD--LOBCOLS end' then do
s1 = ANodeClear(m'.SUB.'dx, 'bp.lobCols',
, subWord(l1, 2), scanPos(s))
dx = dx + 1
call scanNl s, 1
e2 = 'expected after lobCols'
if \(scanSqlId(scanSkip(s)) & m.s.val=='FROM')then
call scanErr s, 'from' e2
if \ (scanSqlId(scanSkip(s)) ,
& m.s.val == 'TABLE') then
call scanErr s, 'from table' e2
if \(scanSqlQuId(scanSkip(s)) & m.s.val.0 ==2)then
call scanErr s, 'from table ct.tb' e2
if scanSqlId(scanSkip(s)) then
if m.s.val \== 'HEADER' then
call scanBack s, m.s.tok
else
call scanNl s, 1
m.s1.to = scanPos(s)
end
else if \ scanNl(s, 1) then
call scanErr s, 'end in .data'
end
else if w1 == '.ENDDATA' then
leave
else if anaBP(m'.SUB', dx, s, nst+1) then do
dx = dx + 1
end
end
m.m.sub.0 = dx-1
call scanNl s, 1
end
m.m.to = scanPos(s)
return 1
endProcedure anaBP
anaBPRebind: procedure expose m.
parse arg m, s
pFr = scanPos(s)
if \ scanSqlId(scanSkipTso(s)) | m.s.val \== 'REBIND' then
return
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'bad rebind'
tri = m.s.val == 'TRIGGER'
eAR = 'expected after rebind ...'
if tri then
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'bad rebind trigger'
if m.s.val \== 'PACKAGE' then
call scanErr s, 'bad rebind ... package'
if \ scanLit(scanSkipTso(s), '(') then
call scanErr s, '(' eAR 'package'
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'collection' eAR '('
col = m.s.val
if \ scanLit(scanSkipTso(s), '.') then
call scanErr s, '.' eAR '(col'
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'package' eAR '(col.'
pkg = m.s.val
if \ scanLit(scanSkipTso(s), '.') then
vers = ''
else do
if \ scanLit(scanSkipTso(s), '(') then
call scanErr s, '(' eAR '(col.pkg.'
/* warning version may start with a digit, not and indent| */
if \ scanUntil(scanSkipTso(s), ')') then
call scanErr s, 'version' eAR '(col.pkg.('
vers = strip(m.s.tok)
if \ scanLit(scanSkipTso(s), ')') then
call scanErr s, ')' eAR '(col.pkg.(version'
end
if \ scanLit(scanSkipTso(s), ')') then
call scanErr s, ')' eAR '(col.pkg.(version'
if tri <> (vers == '') then
call scanErr s, 'rebind tri='tri 'but vers='vers
call aNodeAdd m'.SUB', 'rebind.'word('pkg tri', tri+1),
, col'.'pkg':'vers, pFr, scanPos(s)
return 1
endProcedure anaBPRebind
scanSkipTso: procedure expose m.
parse arg m
do forever
call scanSpaceOnly m
if substr(m.m.src, m.m.pos) <> '-' ,
& substr(m.m.src, m.m.pos) <> '+' then
return m
if \ scanNl(m, 1) | word(m.s.src, 1) == '.ENDDATA' then
return m
end
endProcedure scanSkipTso
/*--- analyze RC/M Model statements ---------------------------------*/
anaModel: procedure expose m.
parse arg m, s, li
parse upper var li bg md o1 oR .
if md == 'ANAPOST' & o1 = 'MODIFYING' then do
if \ (scanNl(s, 1) & translate(scanLook(s, 14)) ,
== '--## DBSYS ') then
call scanErr s, 'line 1 after anaPost'
if scanNl(s, 1) then
l1 = translate(scanLook(s))
m.m.verb = 'AnaPosHea'
if space(subWord(l1, 1, 3), 1) == '--## FUN =' then
m.m.obj = word(l1, 4)
else if left(l1, 14) == '--## ANALYS' ,
| left(l1, 14) == '--## RECOVE' then /* very old */
m.m.obj = left(word(l1, 2) , 3)
else
call scanErr s, 'line 2 after anaPost'
do while scanNl(s, 1),
& ( abbrev(m.s.src, '--## ') ,
| abbrev(m.s.src, '--##* ') | m.s.src = '' )
end
if m.m.obj == 'rec' & \ abbrev(m.s.src, '.DISCONN ') then
call scanErr s, 'no disconn after anaPost recovery'
return 1
end
else if bg \== '--##BEGIN' then do
call scanErr s, 'no model begin'
end
else if wordPos(md, 'CHKSTART: ANAPOST') > 0 then do
m.m.verb = strip(left(md, 8))
call scanNl s, 1
end
else if o1 \== 'OBJ' then do
call scanErr s, 'no OBJ in model begin'
end
else do
parse var md mCr '.' mPr '.' mMdl
if mMdl = '' then
call scanErr s, 'bad model'
m.m.verb = 'md.'mCr'.'mPr'.'mMdl
ll = anaModelOverflow(m, s, m.m.fr)
parse var ll . . . ty ':' cr '.' nm ':'
if wordPos(strip(ty), 'INDEX TABLE TABLESPACE') < 1 then
call scanErr s, 'bad model begin objType' oR
o = ddlGetNew(strip(ty), strip(cr), strip(nm))
m.m.obj = o
call mAdd o'.ANO', m
if \ scanCom(s) then
call scanErr s, 'second model line missing'
parse upper var m.s.tok cc t2 q2 '.' n2 ':'
if cc \== '--##' then
call scanErr s, 'second model line bad'
else if t2 \== 'DBTS' then
call scanErr s, 'second model bad objType' o1
else if m.o.type == 'TB' then
call ddlLink o, 'PAR', 'TS', strip(q2), strip(n2)
else if \ (m.o.type == 'IX' | ( m.o.type == 'TS' ,
& q2 == m.o.qual & n2 == m.o.name) ) then
call scanErr s, 'second model line dbTs <> dbTs'
call scanNl s
end
do forever
li = scanLook(s)
parse upper var li bg m2 .
if bg == '--##' | bg == '--##SYNC' ,
| bg == '' | bg == '--' then
/* ????? | bg == '' | abbrev(strip(li), '-- LOAD FROM ') ??? */
call scanNl s, 1
else if bg == 'LOCK' then do
call scanSqlStop s
end
else if mMdl == 'UNLOAD$R' then do
return 1
end
else if abbrev(bg, '.') then do
if anaBp(m'.SUB', m.m.sub.0 + 1, s, 0) then
m.m.sub.0 = m.m.sub.0 + 1
end
else if bg == '--##.SYNC' then do
bPos = scanPos(s)
ll = anaModelOverflow(m, s)
s1 = ANodeAdd(m'.SUB', 'bp.SYNC', subWord(ll, 2),
, bPos, scanPos(s))
end
else if bg \== '--##END' then
call scanErr s, 'bad model line bg='bg'|'
else if md \== m2 then
call scanErr s, 'mismatches end for model' md
else do
call anaModelOverflow m, s, scanPos(s)
return 1
end
end
endProcedure anaModel
/*--- if a comment overflows 72 characters,
ana will put it on the next line,
without marking it as comment => exe fails
here we mark the continuation with --++
and piece the whole comment together ---------------------*/
anaModelOverflow: procedure expose m.
parse arg m, s, pFr
ll = left(m.s.src, 72)
do lx=1 to 3
if \ scanNl(s, 1) then
leave
one = left(m.s.src, 72)
cx = verify(one, ' ')
if cx < 1 then do
call scanNl s, 1
leave /* empty line might occur at end of overflow*/
end
else if substr(one, cx, 1) == '.' then
leave /* probably batch process command */
else if substr(one, cx, 2) \== '--' then
ll = ll || one
else if substr(one, cx, 4) == '--++' then
ll = ll || substr(one, cx+4)
else
leave
end
ll = strip(ll, 't')
if lx > 1 & pFr \== '' then
s1 = aNodeAdd(m'.SUB', 'cont', ll, pFr, scanPos(s))
return ll
endProcedure anaModelOverflow
/*--- analyze sql DDL statement -------------------------------------*/
anaDdl: procedure expose m.
parse arg m, s
if \ scanSqlId(scanSkip(s)) then do
if scanLit(s, ';') then
return 0
call scanErr s, 'no id to start ddl'
end
v = m.s.val
m.m.verb = v
if wordPos(v, 'ALTER CREATE DROP') > 0 then
call anaACD m, s
else if wordPos(v, 'COMMENT COMMIT LABEL RENAME SET') > 0 then do
/* say 'ignoring' scanPos(s) m.s.tok scanLook(s, 50) */
call scanSqlStop s
return 0
end
else
call scanErr s, 'implement verb' v
call scanSqlStop s
return 1
endProcedure anaDdl
/*--- analyze sql DDL alter/create/drop -----------------------------*/
anaACD: procedure expose m.
parse arg m, s
v = m.m.verb
s1 = aNodeAdd(m'.SUB', 'ddlHead', , m.m.fr)
types = 'ALIAS DATABASE FUNCTION INDEX PROCEDURE' ,
'SEQUENCE SYNONYM TABLE TABLESPACE TRIGGER VIEW'
do sx=1
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'type/prelude expected'
if wordPos(m.s.val, types) > 0 then
leave
if v <> 'CREATE' | sx >= 5 then
call scanErr s, 'after' v 'expected one of' types
m.s1.obj = strip(m.s1.obj m.s.val)
end
ty = m.s.val
if \ scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then
call scanErr s, 'name expected after' v ty
if v == 'CREATE' & ty == 'TABLESPACE' then
nm = m.s.val
else do
if m.s.val.0 == 1 then
m.m.obj = ddlGetNew(ty, , m.s.val.1)
else
m.m.obj = ddlGetNew(ty, m.s.val.1, m.s.val.2)
call mAdd m.m.obj'.ANO', m
end
m.s1.to = scanPos(scanSkip(s))
if ty == 'INDEX' then
call anaDdlIx m, s
else if ty == 'TABLE' then
call anaDdlTb m, s, m.s1.obj
else if ty == 'TABLESPACE' then
call anaDdlTs m, s, nm
else if ty == 'VIEW' then
call anaDdlVw m, s
else if wordPos(ty, 'PROCEDURE TRIGGER') > 0 then do
if scanSqlBeginEnd(s) then
call scanBack s, ';'
end
return
endProcedure anaACD
/*--- analyze sql DDL for index -------------------------------------*/
anaDdlIx: procedure expose m.
parse arg m, s
o = m.m.obj
if m.m.verb == 'CREATE' then do
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'ON' then
call scanErr s, 'ON expected'
call anaDdlLinkQuId o, s, 2, par, 'TB'
end
else if m.m.verb \== 'DROP' then do
call anaDDlPart m, s
end
do while scanSqlForId(s, 'PIECESIZE')
id = m.s.val
if id \== 'PIECESIZE' then
call scanErr s, 'piecesize expected'
call anaDdlSetNumUnit o, s, id
call aNodeAdd m'.SUB', 'at.'id, ,m.s.idBef,
, scanPos(scanSkip(s))
end
return 1
endProcedure anaDdlIx
/*--- analyze sql DDL for table -------------------------------------*/
anaDdlTb: procedure expose m.
parse arg m, s, subTy
o = m.m.obj
do while scanSqlForId(s, 'IN PARTITION')
id = m.s.val
if id == 'IN' then do
call anaDdlLinkQuId o, s, 2, par, 'TS'
iterate
end
if id == 'PARTITION' then do
id = 'PARTBYSZ'
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'BY' then
iterate
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'SIZE' then
iterate
m.o.id = ''
if scanSqlId(scanSkip(s)) then do
if m.s.val \== 'EVERY' then do
call scanBack s, m.s.tok
end
else do
call anaDdlSetNumUnit o, s, id
m.o.id = 'every' m.o.id
end
end
m.o.id = 'by size' m.o.id
end
else
call scanErr s, 'bad forId'
call aNodeAdd m'.SUB', 'at.'id, , m.s.idBef,
, scanPos(scanSkip(s))
end
if m.m.verb == 'CREATE' & m.o.PAR == '' then
if subTy <> 'GLOBAL TEMPORARY' then
call scanErr s, 'IN db.ts missing'
return
endProcedure anaDdlTb
/*--- analyze sql DDL for tableSpace --------------------------------*/
anaDdlTs: procedure expose m.
parse arg m, s, nm
o = m.m.obj
if m.m.verb \== 'CREATE' then
call anaDDlPart m, s
cNum = 'NUMPARTS MAXPARTITIONS SEGSIZE FREEPAGE MAXROWS'
do while scanSqlForId(s, 'in dsSize' cNum)
id = m.s.val
if id == 'IN' then do
if m.m.verb \== 'CREATE' | o \== '' then
call scanErr s, 'in: duplicate or not in Create'
if \ scanSqlQuId(scanSkip(s)) & m.s.val.0 <> 1 then
call scanErr s, 'db name expected'
o = ddlGetNew('TS', m.s.val, nm)
m.m.obj = o
call mAdd o'.ANO', m
end
else if o == '' then
call scanErr s, id 'before in'
else if id == 'DSSIZE' then
call anaDdlSetNumUnit o, s, dsSize
else if wordPos(id, cNum) > 0 then
call anaDdlSetNum o, s, id
else
call scanErr s, 'bad forId'
call aNodeAdd m'.SUB', 'at.'id, , m.s.idBef,
, scanPos(scanSkip(s))
end
if o == '' then
call scanErr s, 'in db missing in' m.m.verb 'ts'
return
endProcedure anaDdlTs
/*--- analyze sql ddl from create to ddlType ------------------------*/
/*--- analyze sql ddl Alter Part ... --------------------------------*/
anaDdlPart: procedure expose m.
parse arg m, s
pFr = scanPos(s)
if translate(scanLook(s, 6)) \== 'ALTER ' then
return
if \ scanSqlId(s) | m.s.val \== 'ALTER' then
call scanErr s, 'why not alter?'
if translate(scanLook(scanSkip(s), 10)) \== 'PARTITION ' then
return
if \ scanSqlId(s) | m.s.val \== 'PARTITION' then
call scanErr s, 'why not partition?'
if \ scanSqlNum(scanSkip(s)) | verify(m.s.tok,'0123456789')>0 then
call scanErr s, 'bad partition number'
call scanSkip s
call aNodeAdd m'.SUB', 'part', , pFr, scanPos(scanSkip(s))
return
endProcedure anaDdlPart
/*--- analyze sql ddl for view --------------------------------------*/
anaDdlVw: procedure expose m.
parse arg m, s
o = m.m.obj
do while scanSqlForId(s, 'FROM JOIN')
if scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then do
call mAdd o'.FRJO', m.s.val
do forever
call scanSqlDeId(scanSkip(s))
if \ scanLit(scanSkip(s), ',') then
leave
if scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then
call mAdd o'.FRJO', m.s.val
else
leave
end
end
end
return 1
endProcedure anaDdlVw
/*--- analyze sql ddl qualified ID and link -------------------------*/
anaDdlLinkQuId: procedure expose m.
parse arg m, s, ll, att, cl
if \ scanSqlQuId(scanSkip(s)) | m.s.val.0 <> ll then
call scanErr s, 'quId with' ll 'quals expected after' att
else if ll == 2 then
call ddlLink m, att, cl, m.s.val.1, m.s.val.2
else
call scanErr s, 'bad ll='ll
return
endProcedure anaDdlLinkQuId
/*--- analyze sql ddl number with unit and set ----------------------*/
anaDdlSetNumUnit: procedure expose m.
parse arg m, s, att
if \ scanSqlNumUnit(scanSkip(s)) then
call scanErr s, 'number Unit expected after' att
else if m.m.att == '' then
m.m.att = space(m.s.val, 0)
else
call scanErr s, att 'already set'
return
endProcedure anaDdlSetNumUnit
/*--- analyze sql ddl number and set --------------------------------*/
anaDdlSetNum: procedure expose m.
parse arg m, s, att
if \ scanSqlNum(scanSkip(s)) then
if att = 'SEGSIZE' then
m.s.val = anaDDlFixSegsize(m, s, att, sp)
else
call scanErr s, 'number expected after' att
else if m.m.att == '' then
m.m.att = space(m.s.val, 0)
else if att == 'FREEPAGE' then
m.m.att = max(m.s.val, m.m.att)
else
call scanErr s, att 'already set'
return
endProcedure anaDdlSetNum
/*--- fix segsize without number ------------------------------------*/
anaDdlFixSegsize: procedure expose m.
parse arg m, s, att
parse value scanPos(s) with pL pC
say s
say m.s.rdr
ii = m.s.rdr'.BUF'
say m.ii.0
say m.ii.pL
if left(m.ii.pL, 2) == ' ' then
m.ii.pl = overlay(0, m.ii.pL)
else
call scanErr s, 'cannot fix segsize;'
say '||fixSegSize; at' pL pC':'m.ii.pL
return 0
nn = strip(m.ii.PL)
endProcedure anaDdlFixSegsize
anaIsRebind: procedure expose m.
parse arg aa, ax
if m.aa.ax.verb \== 'bp.CALL' ,
| translate(word(m.aa.ax.obj, 1)) \== 'DSN' then
return 0
ay = ax + 1
return translate(word(m.aa.ax.obj, 1)) == 'DSN',
& m.aa.ay.verb == 'bp.DATA' ,
& abbrev(m.aa.ay.sub.1.verb, 'rebind.')
endProcedure anaIsRebind
/* aOpt: handle option member ****************************************/
/*--- read aOpt (if it exists) --------------------------------------*/
aOptRead: procedure expose m.
parse arg m, m.m.dsn
m.m.0 = 0
if m.m.dsn <> '' then
if sysDsn("'"m.m.dsn"'") == 'OK' then
call readDsn m.m.dsn, 'M.'m'.'
if m.m.0 >= 1 & translate(word(m.m.1, 1)) \== 'DBX' then
call err 'bad first line in' m.m.dsn '1:' m.m.1
m.m.opts = ''
if m.m.0 >= 2 then
m.m.opts = translate(space(m.m.2, 1))
m.m.aOpt = ''
if m.m.0 >= 3 then
if translate(word(m.m.3, 1)) \== 'AOPT' then
call err 'aOpt expected in' m.m.dsn '3:' m.m.3
else
m.m.aOpt = translate(space(subword(m.m.3, 2), 1))
do ix=1 to m.m.0 while \ abbrev(m.m.ix, 'anaPost pre ')
end
m.m.preBegin = ix
return
endProcedure optRead
/*--- write aOpt (if it exists) -------------------------------------*/
aOptWrite: procedure expose m.
parse arg m, ch
ox = m.m.preBegin
m.m.ox = 'anaPost pre' m.myTst
do ix=1 to m.ch.0
ox = ox + 1
m.m.ox = ' ' m.ch.ix
end
if m.m.dsn <> '' then
call writeDsn m.m.dsn '::f', 'M.'m'.', ox, 1
return
endProcedure aOptWrite
/*--- issue an warning or abend with an error
depening on option in aOpt ------------------------------------*/
aOptErr: procedure expose m.
parse arg key, eMsg
say 'aOptErr key='key
say 'warning:' eMsg
return
if m.opt \== 1 then do /* try to read option file */
m.opt = 1
dsn = translate(m.myddl)
bx = pos('ANA(', dsn)
if bx < 1 then
call err 'ana( not found in' dsn"\n"eMsg
dsn = overlay('OPT(', dsn, bx)
if bx+12 = length(dsn) then
dsn = left(dsn, length(dsn)-2)')'
syD = sysDsn("'"dsn"'")
if syD \== 'OK' then
call err dsn '->' syD"\n"eMsg
call readDsn dsn, 'M.OPT.'
end
do ox=1 to m.opt.0
if translate(word(m.opt.ox, 1)) == translate(key) then do
say 'ignoring error' eMsg
say ' because option' strip(m.opt.ox)
return 1
end
end
call err 'no option' key 'in' dsn"\n"eMsg
endProcedure aOptErr
/* ANode class *******************************************************/
ANodeClear: procedure expose m.
parse arg m
call oClear(oMutate(m, m.clANode))
parse arg , m.m.verb, m.m.obj, m.m.fr, m.m.to
return m
endProcedure ANodeClear
aNodeAdd: procedure expose m.
parse arg a, verb, obj, fr, to
m.a.0 = m.a.0 + 1
return aNodeClear(a'.'m.a.0, verb, obj, fr, to)
endProcedure aNodeAdd
/* DDL class *********************************************************/
ddlGetNew: procedure expose m.
parse arg ty, qu ., nm .
if symbol('m.ddl_types.ty') == 'VAR' then
ty = m.ddl_types.ty
if symbol('m.ddl.ty.qu.nm') == 'VAR' then
return m.ddl.ty.qu.nm
if symbol('m.ddl.ty.0') == 'VAR' then
m.ddl.ty.0 = m.ddl.ty.0 + 1
else do
m.ddl_types = m.ddl_types ty
m.ddl.ty.0 = 1
end
if symbol('m.clddl.ty') == 'VAR' then
n = oClear(oMutate('DDL.'ty'.'m.ddl.ty.0, m.clddl.ty))
else
n = oClear(oMutate('DDL.'ty'.'m.ddl.ty.0, m.clddl))
m.ddl.ty.qu.nm = n
m.n.type = ty
m.n.qual = qu
m.n.name = nm
return n
endProcedure ddlGetNew
ddlLink: procedure expose m.
parse arg o, f, ty, qu, nm
l = ddlGetNew(ty, qu, nm)
if m.o.f == '' then
m.o.f = l
else if l \== m.o.f then do
a = m.o.f
call aOptErr 'post.link.'m.o.type'.'f,
, 'old objLink' m.o.type':'m.o.qual'.'m.o.name'*'f,
|| '=>'a'='m.a.qual'.'m.a.name '<>' ty':'qu'.'nm
end
return
endProcedure ddlLink
ddlPar: procedure expose m.
parse arg o
if o == '' | m.o.par == '' then
return ''
return m.o.par
endProcedure ddlPar
ddlAddAlt: procedure expose m.
parse arg f, a, aO, aN, aForce
o = ddlFilter(a, aO)
n = ddlFilter(a, aN)
say m.f.type m.f.qual'.'m.f.name '==>' m.f.acd,
', fun='m.f.fun 'add' a':' aO'='o '->' aN'='n
if aForce == 1 then
call mAdd chOpt, ' ' a '? ->' n
else if o = n then
return
else
call mAdd chOpt, ' ' a o '->' n
m.f.alt.0 = m.f.alt.0 + 1
ff = oClear(oMutate(f'.ALT.'m.f.alt.0, m.clAON))
m.f.alt.a = ff
m.ff.att = a
m.ff.old = o
m.ff.new = n
return
endProcedure ddlAddAlt
/*--- alter tables: drop partition by size clause ------------------*/
ddlAltPartBySz: procedure expose m.
do tx=1 to m.ddl.tb.0
t1 = 'DDL.TB.'tx
if m.t1.partBySz \== '' then do
m.t1.fun = 'a'
call ddlAddAlt t1, partBySz, m.t1.partBySz , '-'
end
end
return
endProcedure
ddlFilter: procedure expose m.
parse arg a, v
if v = '' then
return '-'
if a=dsSize then do
if abbrev(v, 0) then
return '-'
if dataType(v, 'n') then
return (v % 1048576) || 'G'
else
return space(v, 0)
end
if wordPos(a, maxPartitions segSize) > 0 & v=0 then
return '-'
if a = maxRows & v = 255 then
return '-'
return v
endProcedure ddlFilter
ddlGetUnl: procedure expose m.
parse arg o
do vx=1 to m.o.aNo.0
ul = m.o.aNo.vx
if abbrev(m.ul.verb, 'md.') then
if wordPos(substr(m.ul.verb, lastPos('.', m.ul.Verb)) ,
, '.UNLOAD .FUNLD') > 0 then
return ul
end
return ''
endProcedure ddlGetUnl
ddlAddParents: procedure expose m.
do ox=1 to m.ddl.ix.0
o = 'DDL.IX.'ox
if '-' == sql2one("select tbCreator, tbName",
"from sysibm.sysIndexes",
"where creator='"m.o.qual"' and name='"m.o.name"'",
, q, , , '--') then
say 'warning no ix' m.o.qual'.'m.o.name 'in DB2'
else
m.o.parOld = ddlGetnew('TB', m.q.tbcreator, m.q.tbname)
end
return /* we do not need parents of tb yet ?????? */
do ox=1 to m.ddl.tb.0
o = 'DDL.TB.'ox
if m.o.par \== '' then
iterate
if '-' == sql2one("select dbName, tsName ,type",
"from sysibm.sysTables",
"where creator='"m.o.Qual"' and name='"m.o.name"'",
, q, , , '--') then
say 'warning no tb' m.o.qual'.'m.o.name 'in DB2'
else if pos(m.q.type, 'AGV') < 1 then
m.o.par = ddlGetnew('TS', m.q.dbName, m.q.tsName)
end
return
endProcedure ddlAddParents
/*--- fill field acd with a=alter, c=create and d=drop --------------*/
ddlGenAcd: procedure expose m.
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
do dy=1 to m.d1.0
o = d1'.'dy
alt = ' '
cre = ' '
drop = ' '
do ax=1 to m.o.ANO.0
a1 = m.o.ano.ax
if m.a1.verb == 'ALTER' then
alt = 'a'
else if m.a1.verb == 'CREATE' then
cre = 'c'
else if m.a1.verb == 'DROP' then
drop = 'd'
end
m.o.acd = alt || cre || drop
say m.o.type m.o.qual'.'m.o.name '==>' m.o.acd,
|| ', fun='m.o.fun', o='o
end
end
return
endProcedure ddlGenAcd
/* positions *********************************************************/
posLess: procedure expose m.
parse arg l1 l2, r1 r2
if l1 = r1 then
return l2 < r2
else
return l1 < r1
/* debug *************************************************************/
dbAllOut: procedure expose m.
parse arg ana
m.o.0 = 0
l = 9999
do dx=1 to m.ana.0
call dbOut o, ana'.'dx, '', l
end
do dx=1 to words(m.ddl_types)
d1 = 'DDL.'word(m.ddl_types, dx)
do dy=1 to m.d1.0
call dbOut o, d1'.'dy, '', l
end
end
tDsn = userid()'.tmp.texv(anaPost)'
call writeDsn tDsn, 'M.O.', , 1
/* call adrIsp "view dataset('"tDsn"')", 4 */
return
dbOut: procedure expose m.
parse arg o, a, pr, l
call mAdd o, pr || o2Text(a, l)
if objCLass(a) == m.clANode then
do sx=1 to m.a.sub.0
call dbOut o, a'.SUB.'sx, pr' ', l
end
if oKindOf(a, m.clDdl) then do
do sx=1 to m.a.aNo.0
call mAdd o, pr' 'a'.ANO.'sx'=>'m.a.aNo.sx
end
do sx=1 to m.a.alt.0
call dbOut o, a'.ALT.'sx, pr' ', l
end
end
return
call out left('', o)'db' o2Text(db)
call mdlsOut db'.MDL', o+2
do sx=1 to m.db.ts.0
call tsOut m.db.ts.sx, o+2
end
/* scan extensions ***************************************************/
/*--- scan until one of the given ids -------------------------------*/
scanSqlForId: procedure expose m.
parse arg s, ids
upper ids
do forever
m.s.idBef = scanPos(s)
if \ scanSqlClass(s) then
return 0
if m.s.sqlClass == ';' then do
call scanBack s, ';'
return 0
end
if m.s.sqlClass == 'i' then
if wordPos(m.s.val, ids) > 0 then
return 1
if m.s.sqlClass == '(' then
call scanSqlSkipBrackets s, 1
end
return 0
endProcedue scanSqlForId
/*--- scan over begin ...; ... end ----------------------------------*/
scanSqlBeginEnd: procedure expose m.
parse arg s
lv = 0
do while scanSqlClass(s)
if m.s.sqlClass == 'i' then do
if m.s.val == 'BEGIN' | m.s.val = 'CASE' then
lv = lv + 1
else if m.s.val \== 'END' then
nop
else if lv < 1 then
call scanErr s, 'unpaired END'
else
lv = lv - 1
end
else if m.s.sqlClass == ';' & lv == 0 then
return 1
else if m.s.sqlClass == '(' then
call scanSqlSkipBrackets s, 1
end
if lv > 0 then
call scanErr s, 'eof with' lv 'unpaired BEGINs'
return 0
endProcedue scanSqlBeginEnd
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , (y // 20) + 1, 1)
timeYear2Z: procedure expose m.
parse arg y
return translate(timeYear2Y(y), 'KLMNOPQRSTABCDEFGHIJ',
, 'ABCDEFGHIJKLMNOPQRST')
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeY2Year
timeZ2Year: procedure expose m.
parse arg i
return timeY2Year(translate(i , 'KLMNOPQRSTABCDEFGHIJ',
, 'ABCDEFGHIJKLMNOPQRST'))
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
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
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procecure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
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
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 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 jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead 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 scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- 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-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
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
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
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 comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
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 scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'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 scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'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 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' 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, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
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 scanSpace 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, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(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, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
interpret objMet(m, 'scanSqlIn2Scan')
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end ************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse arg sys, conCla
call sqlIni
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if conCla = 'r' | (conCla = '' & pos('/', sys) <= 0) then
conCla = m.class_sqlConn
else if conCla = 'c' | conCla = '' then
conCla = m.class_sqlCsmConn
else if conCla = 'w' then
conCla = m.class_sqlWshConn
m.sql_conCla = conCla
m.sql_conRzDB = sys
if conCla \== m.class_sqlConn then
return
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format ----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'",
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 > 0 then do" ,
"; wStem = m''.BUF'';' classMet(cl, 'jWriteMax')'; end;'",
"'wStem = qStem;' classMet(cl, 'jWrite')" ,
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end ********************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2StrZYX return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2StrZYX return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "o2String return classGenO2Str(cl)" ,
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classGenO2Str: procedure expose m.
parse arg cl
if cl == m.class_v then
return "return m.m"
else if cl == m.class_w then
return "return substr(m, 2)"
else if cl == m.class_s then
return "return m"
else
return "\-\"
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class 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
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* 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>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
parse source m.err_os .
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: ------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then
interpret m.err_handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay then
call saySt st
if m.err_sayOut & \ (m.err_saysay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/
}¢--- A540769.WK.REXX(ANAPOT1) cre=2015-11-09 mod=2015-11-12-07.58.49 A540769 ---
$#@ $*( find anaPost anO mit zugehörigem anP
$*)
$=dbSys = DVBP
msk = 'DSN.DBY'$dbSys'.*.%%%.D15*.**'
ouP = '~WK.TEXT(ANAPO'iiRz2P(sysvar(sysnode))iiDbSys2c($dbSys)
cx = 13
cy = 22
call csiOpen c, msk
$<>
$>. fEdit(ouP'1)', 'e')
do while csiNext(c, r)
if auf <> substr(m.r, cx, 8) then do
auf = substr(m.r, cx, 8)
lst = ''
end
q4 = substr(m.r, cy, 4)
if q4 = 'ANO.' | q4 = 'REO.' then
lst = lst substr(m.r, cy)
else if q4 = 'ANP.' | q4 = 'REP.' then
if wordPos(overlay('O', substr(m.r, cy), 3), lst) > 0 then
$$- m.r
end
$#out 20151112 07:58:41
$#out 20151112 07:57:41
}¢--- A540769.WK.REXX(ANAPOT2) cre=2015-11-09 mod=2015-11-12-08.04.33 A540769 ---
//A540769Y JOB (CP00,KE50),'DB2 REO', 00010000
// MSGCLASS=T,TIME=1440, 00020000
// NOTIFY=&SYSUID,REGION=0M, 00030000
// SCHENV=DB2,CLASS=M1 00040000
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99, 00020001
// PARM='%WSH'
//SYSPROC DD DSN=A540769.WK.REXX,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$#@ $*( copy anO/P and anR/P to tmp lib and generate calls
$*)
$<~WK.TEXT(ANAPOBP1)
$>~WK.TEXT(ANAPOBP2)
cx = 13
cy = 22
$=p= A540769.TMP.ANAP
sx = 0
$for i $@¢
sx = right(sx + 1, 4, 0)
if sx > 50 then leave
j = strip($i)
dbSy = substr(j, cx-5, 4)
auf = substr(j, cx, 8)
q4 = substr(j, cy, 4)
qR = strip(substr(j, cy+4))
if ddl.auf \== 1 & sysDsn("'DSN.DBX"dbSy".DDL("auf")'")==ok then $@¢
ddl.auf = 1
call readDsn "DSN.DBX"dbSy".DDL("auf")", i.
call writeDsn $p || dbSy".DDO(S"sx") ::f", i., , 1
$$- 'PRE' dbSy auf ${p}dbSy".DDO(S"sx")" qR
$!
if q4 = 'ANP.' then
f = 'ANA'
else
f = 'REC'
call readDsn "DSN.DBY"dbSy"."auf"."left(q4,2)"O."substr(j, cy+4), i.
call writeDsn $p || dbSy"."left(q4, 2)"O(S"sx") ::f", i., , 1
call readDsn "DSN.DBY"dbSy"."auf"."left(q4,2)"P."substr(j, cy+4), i.
call writeDsn $p || dbSy"."left(q4, 2)"P(S"sx") ::f", i., , 1
$$- f dbSy auf ${p}dbSy"."left(q4, 2)"O(S"sx")" qR
$!
$#out 20151109 16:47:12
$#out 20151109 16:45:55
}¢--- A540769.WK.REXX(ANAPOXX) cre=2015-11-12 mod=2015-11-12-11.29.27 A540769 ---
/* rexx ***************************************************************
edit macro for superc: exclude as much as possible
***********************************************************************/
call errReset 'hi'
call adrEdit 'macro (spec) PROCESS'
call adrEdit "f p'=' all"
call adrEdit "x '"left('', 72)"' 1 all"
call adrEdit "x '1 ISRSUPC - MVS/PDF FILE/LINE/WORD/BYTE' 1 all",4
call adrEdit "x ' NEW: ' 1 all",4
call adrEdit "x ' LISTING OUTPUT SECTION' 1 all",4
call adrEdit "x ' ID SOURCE LINES ' 1 all",4
call adrEdit "x ' ----+----1----+----2----+----3----+----' 1 all",4
call adrEdit "x ' D - ' 1 all",4
exit
nicht leer 1
nicht leer 3
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(ATTS) cre=2010-04-17 mod=2010-04-17-18.14.22 A540769 -----
$<.fileList(file('dsn.mfunl'), 'r')
$@for fi $@¢
$$ dataset('$fi') $-{tsoAtts($fi)}
$!
$#out 20100417 18:13:50
dataset('DSN.MFUNL.MF01A1P.A101A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A101A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A102A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A102A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A105A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A105A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A130A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A130A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A131A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A131A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A137A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A137A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A138A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A138A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A141A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A141A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A200A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A200A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A202A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A202A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A230A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A230A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A401A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A401A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF01A1P.A903A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF01A1P.A903A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A701A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A701A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A702A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A702A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A707A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A707A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A708A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A708A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A709A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A709A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A714A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A714A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF02A1P.A716A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF02A1P.A716A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
dataset('DSN.MFUNL.MF03A1P.A009A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.MF03A1P.A009A.P00001.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00002.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00003.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00004.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00005.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00006.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00007.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00008.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00009.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00010.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00011.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00012.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00013.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00014.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00015.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00016.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00017.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00018.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00019.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00020.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00021.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00022.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00023.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00024.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00025.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00026.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00027.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00028.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00029.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00030.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00031.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00032.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00033.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00034.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00035.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00036.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00037.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00038.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00039.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00040.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00041.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00042.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00043.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00044.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00045.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00046.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00047.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00048.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00049.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00050.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00051.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00052.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00053.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00054.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00055.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00056.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00057.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00058.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00059.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00060.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00061.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00062.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00063.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00064.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF03A1P.A009A.P00065.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATA
dataset('DSN.MFUNL.MF150P01.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P01.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P02.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P02.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P03.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P03.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P04.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P04.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P05.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P05.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P06.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P06.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P07.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P07.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P08.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P08.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P09.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P09.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P10.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P10.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P11.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P11.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P12.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P12.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P13.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P13.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P14.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P14.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P15.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P15.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P16.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P16.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P17.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P17.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P18.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P18.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P19.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P19.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P20.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P20.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.MF150P21.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DEFAULT
dataset('DSN.MFUNL.MF150P21.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EYY0X)
dataset('DSN.MFUNL.OE02A1P.A401A.PUN') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(DE
dataset('DSN.MFUNL.OE02A1P.A401A.UNL') DSORG(PS) MGMTCLAS(COM#A064) DATACLAS(EY
$#out 20100417 18:01:12
dataset(DSN.MFUNL.MF01A1P.A101A.PUN) DSORG(PS) MGMTCLAS(COM#E000) DATACLAS(DEFA
dataset(DSN.MFUNL.MF01A1P.A130A.PUN) DSORG(PS) MGMTCLAS(COM#E000) DATACLAS(DEFA
$#out 20100417 17:59:34
}¢--- A540769.WK.REXX(BESEL) cre=2011-05-27 mod=2011-05-27-16.52.09 A540769 ----
//A540769V JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='WSH'
//SYSPROC DD DSN=A540769.WK.REXX,DISP=SHR
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$#@
$@do ix=1 $@¢
$@=¢
select * from
oa1a03.tbe010a1
fetch first 10 rows only
$! $| call sqlStmtsOpt
call sleep 10
$!
//*OUT DD SYSOUT=*
}¢--- A540769.WK.REXX(BESENWAG) cre=2012-09-04 mod=2015-12-08-08.24.32 A540769 ---
/* rexx
Besenwagen
aufruf durch db2Cpg01
start job dsn.besenwag.<dbSy>(qcsBesXp)
warten (max 1h) bis job fertig ist
5. 9.12 Walter: vergessene Copies von db2v10nfm nachholen
***********************************************************************/
parse arg dbSy
lib = 'DSN.BESENWAG.'dbSy
bJob = "'"lib"(qcsBesXp)'"
fini = "'"lib"(finish)'"
if sysDsn(bJob) <> 'OK' then do
say 'besenwagen for' dbSy 'job fehlt:' bJob
exit 0 /* 0 nicht 4 damit controlSummary trotzdem laeuft */
end
say 'start besenwagen for dbSystem' dbSy
if sysDsn(fini) == 'OK' then
call adrTso "delete" fini
call adrTso "sub" bJob
tEnd = time('e') + 3600
do while time('e') < tEnd
call sleep 60
if sysDsn(fini) == 'OK' then do
say 'end Besenwagen, member' fini 'is now OK'
exit 0
end
end
say 'Timeout Besenwagen: member' fini 'fehlt zulange'
exit
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(BESENWAR) cre=2012-09-05 mod=2012-09-21-13.20.40 A540769 ---
$#@
$=dbSy=DBTF
$=hh=3
$=partLim=999999999
$=previewOnly=0
call sqlConnect $dbSy
$;
$<@/sql/
$=ptaInc =- $dbSy = 'DBOF' & sysvar('SYSNODE') == 'RR2'
if $ptaInc then $@=¢
with frTo as
(
select case when strip(min(dbName)) like '_*' and min(dbName) > 'A*'
then left(min(dbName), 1) else ''
end fr,
case when strip(max(dbName)) like '_*'
then left(max(dbName), 1) else ''
end || x'FFFF' to
FROM DLC.OBJECTS_V13
WHERE EXCLUDE='I' AND NAME='QDDBOF INCL EXCLUDES'
)
, p as
$! else $@=¢
with p as
$!
$@=¢
(
SELECT PT.DBNAME, pt.tsName, pt.partition,
( SELECT char(timestamp) || icType
FROM SYSIBM.SYSCOPY CP
WHERE PT.DBNAME = CP.DBNAME
AND PT.TSNAME = CP.TSNAME
AND cp.dsNum in (PT.PARTITION, 0)
AND CP.ICTYPE IN ('F','R','X')
order by timestamp desc
fetch first 1 row only
) laFull,
r.nActive,
COPYLASTTIME,
COPYUPDATEDPAGES,
COPYCHANGES,
COPYUPDATETIME
---- end @proc selIncrCopy: select fullcopy etc. --------------------
FROM SYSIBM.SYSDATABASE DB
$!
if $ptaInc then $@=¢
join frTo
on db.name >= frTo.fr and db.name <= frTo.to
$!
$@=¢
join SYSIBM.SYSTABLESPACE TS
on DB.NAME = PT.DBNAME
join SYSIBM.SYSTABLEPART PT
on DB.NAME = TS.DBNAME
AND TS.NAME = PT.TSNAME
left join SYSIBM.SYSTABLESpaceStats r
on r.dbid = db.dbid
and r.psid = ts.psid
and r.partition = pt.partition
WHERE 0 = 0
---- end @proc missFUllcopies1: fehlende Fullcopies -----------------
---- begin @proc exclude ----------------------------------------------
----- begin @proc exclGen: gemeinsame excludes -------------------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (PT.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME LIKE 'DGDB%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE 'DGO%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE '%A1X%') -- Neue Prototypen
AND NOT (PT.DBNAME LIKE 'DAU%') -- Schulung Gerrit
AND NOT (PT.DBNAME LIKE 'IDT%') -- ibm tools
---- end @proc exclGen: gemeinsame excludes ------------------------
AND NOT (PT.DBNAME LIKE 'OE02%') -- Mail Ivo Eichmann
AND NOT (PT.DBNAME LIKE 'CSQ%') -- M-QUEUE DATENBANK
---- end @proc exclude ---------------------------------------------
---- end @proc exclGen: gemeinsame excludes -------------------------
AND NOT (PT.DBNAME = 'XC01A1P' AND PT.TSNAME LIKE 'A2%' )
-- EOS: Armin Breyer
AND NOT (PT.DBNAME = 'XR01A1P' AND PT.TSNAME LIKE 'A2%' )
-- ERET: Armin Breyer
AND NOT (PT.DBNAME = 'CSQDBOF' AND PT.TSNAME like 'TSBLOB%' )
---- end @proc exclude ----------------------------------------------
AND DB.TYPE NOT IN ('T','W')
---- begin @proc missFUllcopies2: fehlende Fullcopies -----------------
AND TS.NTABLES <> 0
AND PT.SPACEF <> -1 -- attention space is sometimes wrong|
and db.Name like 'WI02%' --- ????
)
, q as
(
select case when laFull < char(current timestamp - $-¢168+$hh$! hours)
then 'full old'
when copyUpdateTime > current timestamp - $hh hours
then 'no newUpd'
when nActive * 0.1 <= COPYUPDATEDPAGES then 'full upda'
when COPYUPDATEDPAGES <> 0 or copyChanges <> 0 then 'inc'
else 'no changes'
end copy,
p.*
from p
)
select *
from q
where left(copy, 2) <> 'no'
ORDER BY DBNAME, TSNAME, PARTITION
WITH UR
$!
$/sql/
call sqlSel
m.inc.0 = 0
m.ful.0 = 0
cAll = 0
pAll = 0
$| $@forWith c $@¢
cAll = cAll + 1
if datatype($NACTIVE, 'n') then
pAll = pAll + $NACTIVE
say left($COPY, 10) left($DBNAME, 8) left($TSNAME, 8) ,
right($PARTITION, 5) left($LAFULL, 30)
say right($COPYCHANGES , 12),
|| right('>'$COPYUPDATEDPAGES, 10),
|| right('%'$NACTIVE, 10) ,
left($COPYLASTTIME, 19),
left($COPYUPDATETIME, 19)
if cAll <= $partLim then
call mAdd if(abbrev($COPY, 'inc'), inc, ful),
, ' INCLUDE TABLESPACE' strip($DBNAME)'.'strip($TSNAME),
'PARTLEVEL' if($PARTITION <> 0, $PARTITION)
$!
$;
say 'total' cAll 'parts and' pAll 'pages'
say ' ' m.inc.0 'incremental and' m.ful.0 'full part copies'
$;
$>DSN.BESENWAG.$dbSy(GENINC)
$@makeList-{INC, FULL NO, 'incremental', cAll, pAll}
$;
$>DSN.BESENWAG.$dbSy(GENFUL)
$@makeList-{FUL, FULL YES, 'full' , cAll, pAll}
$; 66
$@proc makeList $@/makeList/
parse arg ,lst, full, tit, cAll, pAll
$** say 'lst' lst 'full' full 'tit' tit 'cAll' cAll 'pAll' pAll
$$- '--' sysvar('sysnode') $dbSy date('s') time()
$$- '-- total : ' cAll 'parts' pAll 'pages'
$$- '--' left(tit, 11) 'copy: ' m.lst.0 'parts'
if $previewOnly then
$$ OPTIONS(PREVIEW)
else
$$ OPTIONS EVENT(ITEMERROR,SKIP)
if m.lst.0 > 0 then $@=¢
$$- ' LISTDEF LST'lst ' -- ' m.lst.0 'parts'
$@do ix=1 to m.lst.0 $$- m.lst.ix
COPY LIST LST$-{lst} COPYDDN(TCOPYD)
PARALLEL $-{full}
SHRLEVEL CHANGE
$!
$/makeList/
$#out 20120921 11:55:08
$#out 20120921 11:54:19
*** run error ***
tsoAlloc rc 12 for alloc dd(CAT1) SHR DSN('DSN.BESENWAG.DBTF.(GENINC)')
$#out 20120921 11:50:55
-- RZ1 DBTF 20120921 11:51:23
-- total : 586 parts 7768857 pages
-- incremental copy: 308 parts
OPTIONS EVENT(ITEMERROR,SKIP)
LISTDEF LSTINC -- 308 parts
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 21
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 22
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 29
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 30
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 33
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 34
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 35
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 38
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 43
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 24
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A104A004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A004 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A106A01 PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A106H01 PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A107A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A108A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A108H PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A006 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A116A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 22
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 23
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 25
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 26
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 27
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 28
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 29
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 30
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 31
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 32
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 33
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 34
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 35
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 37
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 38
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 39
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 41
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 43
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 44
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 45
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 46
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 47
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 48
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 49
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 50
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 51
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 52
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 53
INCLUDE TABLESPACE WI02A1T.A301A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A611A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A702A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A703A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A707A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 2
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 3
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 4
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 5
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 6
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 7
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 8
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 9
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 10
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 11
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 13
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 15
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 16
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 18
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 20
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 21
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 22
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 23
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 25
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 26
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 27
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 28
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 29
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 30
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 31
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 32
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 33
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 34
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 35
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 36
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 37
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 38
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 41
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 42
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 43
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 44
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 45
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 46
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 51
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 52
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 53
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 54
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 55
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 56
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 57
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 58
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 59
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 60
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 61
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 62
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 63
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 64
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 68
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 69
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 70
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 73
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 74
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 75
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 76
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 77
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 79
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 80
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 81
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 87
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 88
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 90
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 91
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 93
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 94
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 95
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 96
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 98
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 99
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 100
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 101
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 102
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 103
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 104
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 106
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 107
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 108
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 109
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 111
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 112
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 113
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 114
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 116
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 117
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 118
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 119
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 121
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 122
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 123
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 124
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 126
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 127
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 128
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 129
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 130
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 131
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 133
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 134
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 135
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 136
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 137
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 138
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 139
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 140
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 141
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 142
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 143
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 144
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 145
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 146
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 147
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 148
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 149
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 150
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 152
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 153
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 157
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 158
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 159
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 161
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 163
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 164
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 165
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 167
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 168
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 169
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 170
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 171
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 172
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 173
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 174
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 176
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 177
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 179
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 180
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 184
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 185
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 186
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 187
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 188
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 189
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 190
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 191
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 192
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 193
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 194
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 195
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 196
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 197
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 199
COPY LIST LSTINC COPYDDN(TCOPYD)
PARALLEL FULL NO
SHRLEVEL CHANGE
-- RZ1 DBTF 20120921 11:51:23
-- total : 586 parts 7768857 pages
-- full copy: 278 parts
OPTIONS EVENT(ITEMERROR,SKIP)
LISTDEF LSTFUL -- 278 parts
INCLUDE TABLESPACE WI01A1T.A040A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A043A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A044A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A101H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A002 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A002 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A010 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103H004 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103H005 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103H006 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105A002 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A002 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A002 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A010 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112H006 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 21
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 24
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 36
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 40
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 42
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A912A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A402A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A403A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A404A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 19
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 47
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 48
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 49
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 50
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 65
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 71
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 72
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 97
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 105
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 156
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 162
COPY LIST LSTFUL COPYDDN(TCOPYD)
PARALLEL FULL YES
SHRLEVEL CHANGE
$#out 20120921 11:48:22
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:48:50
-- total : 586 parts 7768857 pages
-- incremental copy: 308 parts
LISTDEF LSTINC -- 308 parts
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A100A PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 21
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 22
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 29
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 30
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 33
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 34
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 35
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 38
INCLUDE TABLESPACE WI02A1T.A101A PARTLEVEL 43
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 24
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A104A004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A003 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A004 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A106A01 PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A106H01 PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A107A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A108A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A108H PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A109A009 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A006 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A116A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A120A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 22
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 23
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 25
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 26
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 27
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 28
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 29
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 30
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 31
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 32
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 33
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 34
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 35
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 37
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 38
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 39
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 41
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 43
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 44
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 45
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 46
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 47
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 48
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 49
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 50
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 51
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 52
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 53
INCLUDE TABLESPACE WI02A1T.A301A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A611A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A702A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A703A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A707A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 2
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 3
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 4
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 5
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 6
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 7
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 8
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 9
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 10
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 11
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 13
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 15
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 16
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 18
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 20
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 21
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 22
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 23
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 25
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 26
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 27
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 28
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 29
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 30
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 31
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 32
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 33
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 34
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 35
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 36
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 37
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 38
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 41
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 42
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 43
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 44
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 45
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 46
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 51
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 52
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 53
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 54
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 55
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 56
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 57
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 58
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 59
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 60
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 61
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 62
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 63
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 64
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 68
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 69
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 70
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 73
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 74
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 75
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 76
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 77
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 79
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 80
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 81
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 87
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 88
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 90
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 91
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 93
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 94
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 95
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 96
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 98
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 99
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 100
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 101
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 102
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 103
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 104
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 106
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 107
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 108
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 109
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 111
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 112
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 113
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 114
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 116
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 117
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 118
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 119
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 121
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 122
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 123
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 124
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 126
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 127
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 128
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 129
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 130
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 131
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 133
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 134
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 135
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 136
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 137
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 138
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 139
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 140
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 141
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 142
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 143
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 144
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 145
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 146
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 147
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 148
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 149
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 150
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 152
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 153
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 157
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 158
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 159
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 161
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 163
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 164
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 165
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 167
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 168
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 169
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 170
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 171
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 172
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 173
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 174
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 176
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 177
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 179
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 180
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 184
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 185
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 186
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 187
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 188
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 189
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 190
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 191
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 192
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 193
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 194
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 195
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 196
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 197
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 199
COPY LIST LSTINC COPYDDN(TCOPYD)
PARALLEL FULL NO
SHRLEVEL CHANGE
-- RZ1 DBTF 20120921 11:48:50
-- total : 586 parts 7768857 pages
-- full copy: 278 parts
LISTDEF LSTFUL -- 278 parts
INCLUDE TABLESPACE WI01A1T.A040A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A043A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A044A PARTLEVEL
INCLUDE TABLESPACE WI02A1T.A100H PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A101H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A102A PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A102H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A002 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A002 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A003 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A004 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A005 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A006 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A007 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A008 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A103A009 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103A010 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A103H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A103H003 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A103H004 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A103H004 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A103H005 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A103H006 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105A002 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A006 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 13
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105A007 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 11
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A105A009 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 16
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A105H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A109A001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A109H001 PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A001 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A002 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A002 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A003 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A112A007 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A112A009 PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A112A010 PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A112H006 PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 17
INCLUDE TABLESPACE WI02A1T.A117A PARTLEVEL 19
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 12
INCLUDE TABLESPACE WI02A1T.A117H PARTLEVEL 14
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 15
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 18
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 20
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 21
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 24
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 36
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 40
INCLUDE TABLESPACE WI02A1T.A191H PARTLEVEL 42
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 1
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 2
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 3
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 4
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 5
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 6
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 7
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 8
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 9
INCLUDE TABLESPACE WI02A1T.A610A PARTLEVEL 10
INCLUDE TABLESPACE WI02A1T.A912A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A402A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A403A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A404A PARTLEVEL
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 19
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 47
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 48
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 49
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 50
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 65
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 71
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 72
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 97
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 105
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 156
INCLUDE TABLESPACE WI03A1T.A601A PARTLEVEL 162
COPY LIST LSTFUL COPYDDN(TCOPYD)
PARALLEL FULL YES
SHRLEVEL CHANGE
$#out 20120921 11:47:40
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:47:41
-- total : 3 parts 39 pages
-- incremental copy: 0 parts
-- RZ1 DBTF 20120921 11:47:41
-- total : 3 parts 39 pages
-- full copy: 3 parts
LISTDEF LSTFUL -- 3 parts
INCLUDE TABLESPACE WI01A1T.A040A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A043A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A044A PARTLEVEL
COPY LIST LSTFUL COPYDDN(TCOPYD)
PARALLEL FULL YES
SHRLEVEL CHANGE
$#out 20120921 11:45:10
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:45:11
-- total : 3 parts 39 pages
-- incremental : 0 parts
-- RZ1 DBTF 20120921 11:45:11
-- total : 3 parts 39 pages
-- full : 3 parts
LISTDEF LSTFUL -- 3 parts
INCLUDE TABLESPACE WI01A1T.A040A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A043A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A044A PARTLEVEL
COPY LIST LSTFUL COPYDDN(TCOPYD)
PARALLEL FULL YES
SHRLEVEL CHANGE
$#out 20120921 11:44:02
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:44:03
-- total : parts pages
-- : M.INC, FULL NO, incremental, cAll, pAll.0 parts
-- RZ1 DBTF 20120921 11:44:03
-- total : parts pages
-- : M.FUL, FULL YES, full , cAll, pAll.0 parts
$#out 20120921 11:40:57
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:40:58
-- total : CALL parts PALL pages
-- INCREMENTAL : 0 parts
-- RZ1 DBTF 20120921 11:40:58
-- total : CALL parts PALL pages
-- FULL : 3 parts
LISTDEF LSTFUL -- 3 parts
INCLUDE TABLESPACE WI01A1T.A040A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A043A PARTLEVEL
INCLUDE TABLESPACE WI01A1T.A044A PARTLEVEL
COPY LIST LSTFUL COPYDDN(TCOPYD)
PARALLEL FULL YES
SHRLEVEL CHANGE
$#out 20120921 11:39:44
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:39:45
-- total : CALL parts PALL pages
-- FULL NO : M.O.170.1.0 parts
-- RZ1 DBTF 20120921 11:39:45
-- total : CALL parts PALL pages
-- FULL YES : M.O.170.1.0 parts
$#out 20120921 11:38:39
OPTIONS EVENT(ITEMERROR,SKIP)
-- RZ1 DBTF 20120921 11:38:39
-- total : CALL parts PALL pages
-- FULL NO : M.O.170.1.0 parts
-- RZ1 DBTF 20120921 11:38:39
-- total : CALL parts PALL pages
-- FULL NO : M.O.170.1.0 parts
$#out 20120921 11:30:26
}¢--- A540769.WK.REXX(BESENWA2) cre=2012-09-21 mod=2012-09-21-10.53.49 A540769 ---
$#@
$=dbSy=DBTF
$=hh=3
$=partLim=999999999
$=previewOnly=0
call sqlConnect $dbSy
$;
$>.fEdit('::v')
$<@/sql/
$=ptaInc =- $dbSy = 'DBOF' & sysvar('SYSNODE') == 'RR2'
if $ptaInc then $@=¢
with frTo as
(
select case when strip(min(dbName)) like '_*' and min(dbName) > 'A*'
then left(min(dbName), 1) else ''
end fr,
case when strip(max(dbName)) like '_*'
then left(max(dbName), 1) else ''
end || x'FFFF' to
FROM DLC.OBJECTS_V13
WHERE EXCLUDE='I' AND NAME='QDDBOF INCL EXCLUDES'
)
, p as
$! else $@=¢
with p as
$!
$@=¢
(
SELECT PT.DBNAME, pt.tsName, pt.partition,
( SELECT char(timestamp) || icType
FROM SYSIBM.SYSCOPY CP
WHERE PT.DBNAME = CP.DBNAME
AND PT.TSNAME = CP.TSNAME
AND cp.dsNum in (PT.PARTITION, 0)
AND CP.ICTYPE IN ('F','R','X')
and timestamp < '2012-09-21-03.20.00'
order by timestamp desc
fetch first 1 row only
) laFull,
r.nActive,
COPYLASTTIME,
COPYUPDATEDPAGES,
COPYCHANGES,
COPYUPDATETIME
---- end @proc selIncrCopy: select fullcopy etc. --------------------
FROM SYSIBM.SYSDATABASE DB
$!
if $ptaInc then $@=¢
join frTo
on db.name >= frTo.fr and db.name <= frTo.to
$!
$@=¢
join SYSIBM.SYSTABLESPACE TS
on DB.NAME = PT.DBNAME
join SYSIBM.SYSTABLEPART PT
on DB.NAME = TS.DBNAME
AND TS.NAME = PT.TSNAME
left join SYSIBM.SYSTABLESpaceStats r
on r.dbid = db.dbid
and r.psid = ts.psid
and r.partition = pt.partition
WHERE 0 = 0
---- end @proc missFUllcopies1: fehlende Fullcopies -----------------
---- begin @proc exclude ----------------------------------------------
----- begin @proc exclGen: gemeinsame excludes -------------------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (PT.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME LIKE 'DGDB%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE 'DGO%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE '%A1X%') -- Neue Prototypen
AND NOT (PT.DBNAME LIKE 'DAU%') -- Schulung Gerrit
AND NOT (PT.DBNAME LIKE 'IDT%') -- ibm tools
---- end @proc exclGen: gemeinsame excludes ------------------------
AND NOT (PT.DBNAME LIKE 'OE02%') -- Mail Ivo Eichmann
AND NOT (PT.DBNAME LIKE 'CSQ%') -- M-QUEUE DATENBANK
---- end @proc exclude ---------------------------------------------
---- end @proc exclGen: gemeinsame excludes -------------------------
AND NOT (PT.DBNAME = 'XC01A1P' AND PT.TSNAME LIKE 'A2%' )
-- EOS: Armin Breyer
AND NOT (PT.DBNAME = 'XR01A1P' AND PT.TSNAME LIKE 'A2%' )
-- ERET: Armin Breyer
AND NOT (PT.DBNAME = 'CSQDBOF' AND PT.TSNAME like 'TSBLOB%' )
---- end @proc exclude ----------------------------------------------
AND DB.TYPE NOT IN ('T','W')
---- begin @proc missFUllcopies2: fehlende Fullcopies -----------------
AND TS.NTABLES <> 0
AND PT.SPACEF <> -1 -- attention space is sometimes wrong|
)
, q as
(
select case when laFull < char(timestamp('2012-09-20-05.00.00')
- $-¢168+$hh$! hours)
then 'full old'
when copyUpdateTime > current timestamp - $hh hours
then 'no newUpd'
when nActive * 0.1 <= COPYUPDATEDPAGES then 'full upda'
when COPYUPDATEDPAGES <> 0 or copyChanges <> 0 then 'inc'
else 'no changes'
end copy,
p.*
from p
)
select *
from q
where -- left(copy, 2) <> 'no'
dbName like 'AV15A%'
ORDER BY DBNAME, TSNAME, PARTITION
WITH UR
$!
$/sql/
call sqlSel $| call fmtFTab
$#out 20120921 10:29:05
$#out 20120921 10:27:02
$#out 20120921 10:25:33
$#out 20120921 10:22:26
$#out 20120921 10:19:52
$#out 20120921 10:19:35
*** run error ***
tsoAlloc rc 12 for alloc dd(CAT1) OLD DSN('V')
$#out
}¢--- A540769.WK.REXX(BETAANA) cre=2012-01-12 mod=2012-04-10-12.06.26 A540769 ---
/**********************************************************************
analyze multiple jobs extracted from beta92 by jcl(beta92ex)
* IAT6140 JOB ==> begin of job
* IAT2000 ==> system
* // ... JOB ==> jobName
* IEF373I ==> step/start
* IEF032I ==> step/stop ==> ela
* cpu: ==> cpu
totalise P02 by system
**********************************************************************/
call errReset 'h'
m.oDsn = '~wk.texw(qrana408)'
if 0 then call betaAna '~wk.texw(qr59)', 'pta0108-59'
if 1 then call betaAna '~tmp.texw(beta0408)', 'prod0408'
if 0 then call betaAna '~wk.texw(qrTf0318)', 'dbt0318-2012019'
exit
betaAna: procedure expose m.
parse arg dsn, m.ii.txt
m.o.0 = 0
call readNxBegin qr, dsn,,10000
st = ''
m.sys.0 = 0
m.ii.jx=0
call s1 '***begin' m.ii.txt
do forever
li = readNx(qr)
if li == '' then
leave
if abbrev(m.li, ' IAT6140 JOB ') then do
call jobEnd st
m.ii.job = ''
m.ii.jx = m.ii.jx+1
m.ii.step.0 = 0
st = 'i'
end
else if state == '' then
iterate
if st == 'i' then do
if strip(substr(m.li, 10, 10)) == 'IAT2000' then do
pJ = wordpos('JOB', m.li)
p1 = wordpos('SELECTED', m.li)
m.ii.sys = word(m.li, p1+1)
m.ii.job = word(m.li, pJ+1)
if pJ < 1 | p1 < 1 | length(m.ii.sys) \== 3 then
call err 'bad iat2000 selected' readnxPos(qr)
st = 'i2'
end
end
if abbrev(m.li, '//') then do
if st == 'j' then
iterate
if st \== 'i2' then
call err '// line in state' st':' ,
(m.qr.buf0x+m.qr.cx) m.li
if word(m.li, 2) \== 'JOB' then
call err '// bad job' readnxPos(qr)
if m.ii.job \== substr(word(m.li, 1), 3) then
call 'job mismatch' m.ii.job substr(word(m.li, 1), 3)
st = 'j'
end
else if state == 'i' then
iterate
if abbrev(m.li, 'IEF373I STEP/') then do
sx = m.ii.step.0 + 1
m.ii.step.0 = sx
m.ii.step.sx.step = strip(substr(m.li, 14, 8))
m.ii.step.sx.start = substr(m.li, 29, 12)
st = 's0'
end
else if abbrev(m.li, 'IEF032I STEP/') then do
if st \== 's0' then
call err 'stepStop but state='st':' ,
(m.qr.buf0x + m.qr.cx) m.li
s1 = ii'.STEP.'m.ii.step.0
if m.s1.step \== strip(substr(m.li, 14, 8)) then
call err 'stepStop but step='m.s1.step':' readnxPos(qr)
m.s1.stop = substr(m.li, 29, 12)
v = m.s1.start
b = m.s1.stop
if substr(v, 8, 1) \== '.' | substr(b, 8, 1) \== '.' ,
| left(v, 4) \== left(b, 4) then
call err 'yearchange start/stop' v'/' || b readnxPos(qr)
m.s1.ela=(((substr(b, 5, 3) - substr(v, 5, 3)) * 24,
+ substr(b, 9, 2) - substr(v, 9, 2)) * 60,
+ substr(b,11, 2) - substr(v,11, 2)) * 60
st = 's1'
end
else if st == 's1' then do
parse var m.li w1 h 'HR' m 'MIN' s 'SEC' .
h = strip(h)
m = strip(m)
s = strip(s)
if w1 \== 'CPU:' | \ (datatype(h,'n') & datatype(m, 'n') ,
& datatype(s,'n')) then
call err 'bad cpu line:' readnxPos(qr)
s1 = ii'.STEP.'m.ii.step.0
m.s1.cpu = ((h*60)+m)*60+s
st = 's2'
end
/* say (m.qr.buf0x + m.qr.cx) m.li */
end
call jobEnd st
call readNxEnd qr
call s1 left('w&w', 20) 'sys cnt ela cpu'
do rx=1 to m.sys.0
call s1 left(m.ii.txt, 20) m.sys.rx.sys,
format(m.sys.rx.cnt, 6, 0) ,
format(m.sys.rx.ela, 8, 2) format(m.sys.rx.cpu, 8, 2)
end
call s1 '***end ' m.ii.txt ,
'with' m.ii.jx 'jobs and' (m.qr.buf0x + m.qr.cx) 'lines'
call writeDsn m.oDsn, 'M.O.', ,1
return
endProcedure betaAna
s1: procedure expose m.
parse arg msg
say msg
ox = m.o.0 + 1
m.o.0 = ox
m.o.ox = msg
return
endProcedure s1
jobEnd: procedure expose m.
parse arg st
if st == '' then
return
do sx = 1 to m.ii.step.0 until m.ii.step.sx.step == 'P02'
end
if sx > m.ii.step.0 then do
say 'no p02 found in job' m.ii.job
return
end
s1 = ii'.STEP.'sx
if m.ii.jx // 100 = 0 then
say 'jobEnd' m.ii.jx m.ii.job m.ii.sys m.s1.step 'ela='m.s1.ela ,
'cpu='m.s1.cpu readnxPos(qr, 0)
do rx = 1 to m.sys.0 until m.sys.rx.sys == m.ii.sys
end
if rx > m.sys.0 then do
m.sys.0 = m.sys.0 + 1
m.sys.rx.sys = m.ii.sys
m.sys.rx.cnt = 0
m.sys.rx.ela = 0
m.sys.rx.cpu = 0
end
m.sys.rx.cnt = m.sys.rx.cnt + 1
m.sys.rx.ela = m.sys.rx.ela + m.s1.ela
m.sys.rx.cpu = m.sys.rx.cpu + m.s1.cpu
if m.s1.ela > 3600 then
call s1 m.ii.job'.p02 ela' m.s1.ela 'cpu' m.s1.cpu ,
'sys' m.ii.sys
return
endProcedure jobEnd
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(BETAFRTO) cre=2012-10-02 mod=2012-10-02-12.46.05 A540769 ---
$#@
$<~tmp.texw(beta093t)
all = '9999'
$@for li $@¢
if \abbrev($li, 'QR') then iterate
fr = word($li, 3)
to = word($li, 4)
do wx = 1 to words(all)
if word(all, wx) = fr then leave
if word(all, wx) > fr then do
all = subword(all, 1, wx-1) fr subword(all, wx)
m.fr = 0
leave
end
end
m.fr = m.fr + 1
do wx = 1 to words(all)
if word(all, wx) = to then leave
if word(all, wx) > to then do
all = subword(all, 1, wx-1) to subword(all, wx)
m.to = 0
leave
end
end
m.to = m.to - 1
$!
tot = 0
last = ''
len = 16
do wx = 1 to words(all)-1
w1 = word(all, wx)
if last <> left(w1, len) then do
if last <> '' then
$$- last right(tot, 5) right(cMin, 5) right(cMax, 5)
last = left(w1, len)
cMin = tot
cMax = tot
end
tot = tot + m.w1
cMin = min(cMin, tot)
cMax = max(cMax, tot)
end
$$- last right(tot, 5) right(cMin, 5) right(cMax, 5)
$#out 20121002 12:44:22
30.09.2012.01:00 1 0 1
30.09.2012.01:19 12 1 14
30.09.2012.01:20 6 6 12
30.09.2012.01:21 3 3 6
30.09.2012.01:26 2 2 3
30.09.2012.01:27 1 1 2
30.09.2012.01:33 0 0 1
30.09.2012.02:59 1 0 1
30.09.2012.05:00 5 1 5
30.09.2012.05:02 2 2 5
30.09.2012.05:04 0 0 2
30.09.2012.06:30 22 0 30
30.09.2012.06:31 20 20 22
30.09.2012.06:32 19 18 21
30.09.2012.06:33 19 17 20
30.09.2012.06:34 18 18 19
30.09.2012.06:35 18 18 19
30.09.2012.06:36 20 17 20
30.09.2012.06:37 20 19 20
30.09.2012.06:38 19 19 20
30.09.2012.06:39 19 18 19
30.09.2012.06:40 19 18 19
30.09.2012.06:43 18 18 19
30.09.2012.06:47 17 16 18
30.09.2012.06:48 17 16 17
30.09.2012.06:49 17 16 17
30.09.2012.06:51 16 15 17
30.09.2012.06:52 16 15 16
30.09.2012.06:56 16 15 16
30.09.2012.06:57 15 15 16
30.09.2012.06:58 16 14 16
30.09.2012.06:59 15 14 16
30.09.2012.07:00 13 13 16
30.09.2012.07:01 16 13 16
30.09.2012.07:03 16 15 16
30.09.2012.07:04 16 14 16
30.09.2012.07:05 16 15 16
30.09.2012.07:06 16 15 16
30.09.2012.07:07 16 14 16
30.09.2012.07:08 15 14 16
30.09.2012.07:09 15 14 15
30.09.2012.07:10 15 14 15
30.09.2012.07:11 15 14 15
30.09.2012.07:12 15 14 15
30.09.2012.07:14 15 14 15
30.09.2012.07:18 15 14 15
30.09.2012.07:19 15 14 15
30.09.2012.07:20 15 14 15
30.09.2012.07:21 15 14 15
30.09.2012.07:22 14 14 15
30.09.2012.07:23 14 13 15
30.09.2012.07:24 14 14 15
30.09.2012.07:25 15 14 15
30.09.2012.07:28 15 14 15
30.09.2012.07:29 14 14 15
30.09.2012.07:30 14 14 15
30.09.2012.07:31 20 14 21
30.09.2012.07:33 20 19 20
30.09.2012.07:36 19 19 20
30.09.2012.07:39 19 18 19
30.09.2012.07:41 18 18 19
30.09.2012.07:43 17 17 18
30.09.2012.07:45 17 16 17
30.09.2012.07:46 17 16 17
30.09.2012.07:51 17 16 17
30.09.2012.07:52 17 16 17
30.09.2012.07:53 17 16 17
30.09.2012.07:54 17 16 17
30.09.2012.07:56 17 16 17
30.09.2012.07:58 17 16 17
30.09.2012.07:59 17 16 17
30.09.2012.08:00 17 16 17
30.09.2012.08:01 17 16 17
30.09.2012.08:02 16 16 17
30.09.2012.08:03 17 16 17
30.09.2012.08:04 17 16 17
30.09.2012.08:07 17 16 17
30.09.2012.08:08 17 16 17
30.09.2012.08:09 17 16 17
30.09.2012.08:13 17 16 17
30.09.2012.08:14 17 16 17
30.09.2012.08:15 17 16 17
30.09.2012.08:16 14 14 17
30.09.2012.08:17 16 14 16
30.09.2012.08:18 15 13 16
30.09.2012.08:19 28 14 29
30.09.2012.08:20 26 25 28
30.09.2012.08:21 22 22 27
30.09.2012.08:22 22 22 23
30.09.2012.08:23 23 22 23
30.09.2012.08:24 23 22 23
30.09.2012.08:25 22 22 23
30.09.2012.08:26 23 22 23
30.09.2012.08:27 23 22 23
30.09.2012.08:28 22 22 23
30.09.2012.08:29 22 21 23
30.09.2012.08:30 22 21 23
30.09.2012.08:31 22 21 23
30.09.2012.08:32 23 22 23
30.09.2012.08:33 22 22 23
30.09.2012.08:34 22 22 23
30.09.2012.08:35 22 22 23
30.09.2012.08:36 22 21 22
30.09.2012.08:37 21 20 22
30.09.2012.08:38 20 20 22
30.09.2012.08:39 21 20 21
30.09.2012.08:40 21 20 21
30.09.2012.08:41 21 20 21
30.09.2012.08:42 21 20 21
30.09.2012.08:43 21 20 21
30.09.2012.08:44 20 20 21
30.09.2012.08:45 21 20 21
30.09.2012.08:46 20 20 21
30.09.2012.08:48 20 19 20
30.09.2012.08:50 20 19 20
30.09.2012.08:51 20 19 20
30.09.2012.08:54 20 18 20
30.09.2012.08:55 20 18 20
30.09.2012.08:56 20 19 20
30.09.2012.08:58 20 19 20
30.09.2012.09:00 20 18 20
30.09.2012.09:01 20 19 20
30.09.2012.09:03 19 19 20
30.09.2012.09:04 20 19 20
30.09.2012.09:09 21 19 21
30.09.2012.09:12 21 19 21
30.09.2012.09:13 20 20 21
30.09.2012.09:14 21 20 21
30.09.2012.09:15 20 20 21
30.09.2012.09:16 21 20 21
30.09.2012.09:20 21 20 21
30.09.2012.09:21 21 20 21
30.09.2012.09:25 21 20 21
30.09.2012.09:27 20 19 21
30.09.2012.09:28 20 19 20
30.09.2012.09:29 20 18 20
30.09.2012.09:30 20 18 20
30.09.2012.09:31 18 18 20
30.09.2012.09:32 19 18 19
30.09.2012.09:33 19 18 19
30.09.2012.09:34 18 18 19
30.09.2012.09:35 19 18 19
30.09.2012.09:36 18 16 19
30.09.2012.09:37 17 16 18
30.09.2012.09:38 13 13 18
30.09.2012.09:41 12 12 13
30.09.2012.09:43 12 12 15
30.09.2012.09:44 11 11 12
30.09.2012.09:47 10 10 11
30.09.2012.09:52 8 8 10
30.09.2012.10:00 8 8 9
30.09.2012.10:08 7 7 8
30.09.2012.10:14 6 6 7
30.09.2012.10:17 5 5 6
30.09.2012.10:32 4 4 5
30.09.2012.11:01 4 4 5
30.09.2012.11:04 3 3 4
30.09.2012.11:34 2 2 3
30.09.2012.12:00 2 2 5
30.09.2012.12:44 1 1 2
30.09.2012.12:49 2 1 2
30.09.2012.12:58 3 1 7
30.09.2012.13:01 4 3 4
30.09.2012.13:06 3 3 4
30.09.2012.13:33 2 2 3
30.09.2012.15:00 11 2 18
30.09.2012.15:01 7 7 11
30.09.2012.15:02 6 6 7
30.09.2012.15:03 4 4 6
30.09.2012.15:35 5 4 5
30.09.2012.16:00 8 5 20
30.09.2012.16:10 7 7 8
30.09.2012.16:12 6 6 7
30.09.2012.16:36 5 5 6
30.09.2012.17:00 21 5 31
30.09.2012.17:01 13 13 26
30.09.2012.17:02 10 10 13
30.09.2012.17:03 8 8 10
30.09.2012.17:05 7 7 8
30.09.2012.17:06 6 6 7
30.09.2012.17:08 4 4 6
30.09.2012.17:30 6 4 25
30.09.2012.17:31 5 5 6
30.09.2012.17:40 4 4 5
30.09.2012.17:45 3 3 4
30.09.2012.17:54 4 3 4
30.09.2012.17:55 3 3 4
30.09.2012.18:00 15 3 25
30.09.2012.18:01 8 8 20
30.09.2012.18:02 7 7 8
30.09.2012.18:03 6 6 7
30.09.2012.18:04 5 5 6
30.09.2012.18:06 4 4 5
30.09.2012.18:14 3 3 4
30.09.2012.18:22 2 2 3
30.09.2012.19:00 19 2 25
30.09.2012.19:01 10 10 19
30.09.2012.19:02 8 8 10
30.09.2012.19:03 6 6 8
30.09.2012.19:05 5 5 6
30.09.2012.19:06 4 4 5
30.09.2012.19:10 3 3 4
30.09.2012.19:26 2 2 3
30.09.2012.20:00 15 2 16
30.09.2012.20:01 4 4 15
30.09.2012.20:02 3 3 4
30.09.2012.20:06 2 2 3
30.09.2012.20:20 1 1 2
30.09.2012.21:00 5 1 12
30.09.2012.21:01 4 4 5
30.09.2012.21:02 3 3 4
30.09.2012.21:03 2 2 3
30.09.2012.21:04 1 1 2
30.09.2012.21:05 0 0 1
30.09.2012.22:00 2 0 3
30.09.2012.22:01 0 0 2
30.09.2012.22:15 1 0 1
30.09.2012.22:24 0 0 1
}¢--- A540769.WK.REXX(BINDCMN) cre=2014-09-24 mod=2015-12-15-17.40.43 A540769 ---
/* REXX ----------------------------------------------------------------
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
m.sql_dbSys = ''
call errReset "hi", "call errReset 'hi'" ,
"; call errSay 'f}'ggTxt; call errCleanup",
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end" ,
"; exit 'error' ggTxt"
parse upper arg fun rest
/*%SYSDATE */
/*%SYSTIME */
say "BINDCMN Vers:" SYSDATE"/"SYSTIME "/Function:" FUN "/" REST
if wordPos(fun, 'DBP PGM EXE RES') < 1 then
return errHelp('i}bad fun' fun 'in:' fun rest)
exit cmnWork(fun, rest)
cmnWork: procedure expose m.
parse arg fun, rest
if pos('?', fun rest) > 0 | fun = '' then
exit help()
if fun <> 'EXE' then
call sqlConnect 'DP4G'
if fun == 'PGM' then
res = doPGM(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'REBIND' then
res = doRebind(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'DBP' then
res = doDBP(anaAI(rest))
else if fun == 'EXE' then
res = doExe()
else if fun == 'RES' then
res = doRes(rest)
else
return errHelp('i}bad args:' fun rest)
if m.sql_dbSys <> '' then
call sqlDisconnect
return res
endProcedure cmnWork
exit 0
anaAI: procedure expose m.
parse arg appl inst rest
if appl = '' then
call err 'i}no arguments'
if rest = '' then
call err 'i}no program:' appl inst rest
i = anaInst(inst)
if i == '' then
call err 'i}bad installDate' inst 'in:' appl inst rest
if length(appl) <> 4 then
call err 'i}bad appl' appl 'in:' appl inst rest
return appl i rest
endProcedure anaAI
ana7: procedure expose m.
parse arg args
parse arg cmPkg f1 com cmJob appl inst rz rest
if length(cmPkg) > 10 then
call err 'i}bad cmPkg' cmPkg 'args:' args
if length(f1) <> 1 then
call err 'i}bad cmFun' f1 'args:' args
if length(com) > 20 then
call err 'i}bad com' com 'args:' args
if length(cmJob) > 20 then
call err 'i}bad cmJob' cmJob 'args:' args
i = word(anaAI(appl inst 'x'), 2)
if length(rz) <> 3 | \ abbrev(rz, 'R') then
call err 'i}bad rz' rz 'args:' args
return cmPkg f1 com cmJob appl i rz rest
endProcedure ana6
anaInst: procedure expose m.
parse arg inst
today = translate('78.56.1234', date('s'), '12345678')
i0 = translate(inst, '000000000', '123456789')
if i0 == '00000000' then
return translate('78.56.1234', inst, '12345678')
else if i0 == '0000' then
return translate('34.12', inst, '1234')substr(today, 6)
else if i0 == '00.00' then
return inst || substr(today, 6)
else if i0 == '00.00.00' then
return left(inst,6)substr(today, 7, 2)right(inst, 2)
else if i0 == '00.00.0000' then
return inst
else
return ''
endProcedure anaInst
doPGM: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindRz" ,
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doPGM
doRebind: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040Rebind",
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doRebind
doDBP: procedure expose m.
parse arg appl inst pgms
call insPgm appl inst, pgms
res = selWri( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindDBP")
call sqlCommit
call sqlDisConnect
return res
endProcedure doDBP
doExe: procedure expose m.
call tsoOpen 'BIND', 'R'
call readDD 'BIND', i., '*'
call tsoClose 'BIND'
ox = 0
ex = 0
ey = ex
ccMax = 0
ccId = 0
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
str = 'b'
do ix = 1 to i.0 /* each line */
/* concat one command */
li = strip(doExeComm(i.ix), str)
if iCmd = '' then
ey = ex + 2
else
ey = ey + 1
e.ey = li
if right(li, 1) == '-' then do
iCmd = iCmd || left(li, length(li)-1)
str = 't'
iterate
end
else if right(li, 1) == '+' then do
iCmd = iCmd || left(li, length(li)-1)
str = 'b'
iterate
end
else do
iCmd = iCmd || li
end
/* we have one command in iCmd */
str = 'b' /* for next cmd */
if iCmd = '' then
iterate
if iFirst == '' then do /* dsn command */
iFirst = strip(iCmd)
iCmd = ''
iterate /* look next bind */
end
if translate(iCmd) = 'END' then do /* end of program */
ox = ox+1 /* result for program */
o.ox = 'res' ccId,
'job' strip(jobInfo(name))'#'strip(jobInfo(num)) ,
'id' m.doExe.iId 'pgm' m.doExe.iPgm
if ccId > 0 then
if length(eM) <= 2000 then
o.ox = o.ox 'err' eM
else
o.ox = o.ox 'err' left(eM, 1997)'...'
ccMax = max(ccMax, ccId)
ccId = 0 /* reset variables */
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
iterate
end
/* we got one bind in iCmd */
do while queued() > 0 to /* clear input queue */
parse pull pOld
say 'err pulled:' pOld
ccMax = max(99, ccMax)
end
say iFirst '=>' space(iCmd, 1) /* execute dsn bind end */
queue iCmd
queue 'end'
cc = adrTso(iFirst, '*')
do tx=1 to m.tso_trap.0 /* say output of bind */
say m.tso_trap.tx
end
cc2 = cc
if cc < 0 | \ datatype(cc, 'n') then
cc2 = 999
if cc2 > 0 then do
ez = ex+1 /* write whole command to err */
e.ez = iFirst
ex = ey
end
eM = doExeMsg(eM, cc2 ccId, iFirst, iCmd)
ccId = max(ccId, cc2)
say e.actMsg
iCmd = '' /* end one bind */
end /* each line */
if iCmd \== '' | iFirst \== '' then
call err 'fileEnd but iCmd='iCmd', iFirst='iFirst
if ccId \== 0 | eM \== '' then
call err 'fileEnd but ccId='ccId', eM='eM
if ex = 0 then do
ex = ex + 1
e.ex = 'ccMax =' ccMax
end
call tsoOpen 'BINDRES', 'W'
call writeDD 'BINDRES', 'o.', ox
call tsoClose 'bindRes'
call tsoOpen 'BINDErr', 'W'
call writeDD 'BINDErr', 'e.', ex
call tsoClose 'BINDErr'
if ccMax <= 4 then
return 'ok ccMax' ccMax 'for exe'
else
return 'err ccMax' ccMax 'for exe'
endProcedure doExe
doExeMsg: procedure expose m. e. ex
parse arg eM, cc2 ccId, iFirst, iCmd
m0 = sysvar(sysNode)
cx = pos('(', iFirst)
if cx > 0 & right(iFirst, 1) == ')' then
m0 = m0'/'substr(iFirst, cx+1, length(iFirst)-cx-1)
else
m0 = m0'/'iFirst
uCmd = translate(iCmd)
cx = pos('PACKAGE(', uCmd)
cy = pos('MEMBER(', uCmd)
if cx > 0 & cy > 0 then do
col = word(substr(iCmd, cx+8), 1)
if right(col, 1) == ')' then
col = left(col, length(col)-1)
mbr = word(substr(iCmd, cy+7), 1)
if right(mbr, 1) == ')' then
mbr = left(mbr, length(mbr)-1)
sCmd = left(iCmd, min(cx, cy)-1) col'.'mbr
end
else do
sCmd = iCmd
end
if length(m0) > 30 then
actM = left(m0, 27)'...' sCmd
else
actM = m0 sCmd
if cc2 > 4 | cc2 < 0 then
e.actMsg = strip(left('error cc='cc2 actM, 80))
else if cc2 > 0 then
e.actMsg = strip(left('warning cc='cc2 actM, 80))
else do
e.actMsg = strip(left('ok cc='cc2 actM, 80))
ex = ex + 1
e.ex = e.actMsg
return eM
end
actM = ''
do tx=1 to m.tso_trap.0
t1 = m.tso_trap.tx
ex = ex + 1
e.ex = left(t1, 80)
if wordPos(word(t1, 1), 'DSNX200I') > 0 then
iterate
j = space(t1, 1)
if j == 'USING CMNBATCH AUTHORITY' ,
| j == 'PLAN=(NOT APPLICABLE)' ,
| j == 'DBRM='m.doExe.iPgm then
iterate
cx = pos('=', j)
if cx > 1 then
if pos('='left(j, cx),
, '=SQLSTATE=CSECT NAME=RDS CODE=') > 0 then
iterate
actM = actM' 'j
end
if eM == '' then
return m0':' actM';'
else if cc2 > ccId then
return m0':' actM';' eM
else
return eM m0':' actM';'
endProcedure doExeMsg
doExeComm: procedure expose m.
parse arg src
res = ''
cy = -1
do forever
cx = pos('/*', src, cy+2)
if cx < 1 then
return res || substr(src, cy+2)
res = res || substr(src, cy+2, cx-cy-2)
cy = pos('*/', src, cx+2)
if cy < 1 then
com = strip(substr(src, cx+2))
else
com = strip(substr(src, cx+2, cy-cx-2))
say '/*' com
w1 = word(com, 1)
if w1 == 'beginRzPgm' then
m.doExe.iPgm = strip(subword(com, 2))
else if w1 == 'id' then
m.doExe.iId = strip(subword(com, 2))
if cy < 1 then
return res
end
endProcedure doExeComm
doRes: procedure expose m.
parse arg cmRes
if ^ (cmRes == 0 | cmRes == 8) then
call err 'cmRes bad cmRes =' cmRes
call readDD bindRes, i., '*'
call tsoClose bindRes
maxCC = 0
if i.0 < 1 then
return err('e}no lines in dd bindRes')
do ix=1 to i.0
parse var i.ix cRes res cJob jobPP cId id cFu pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
if length cFu <> 1 & pos('@', cFu) > 0 then do
cFu = ' '
parse var i.ix cRes res cJob jobPP cId id pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
end
parse var pkgTst pkg '@' tst
parse var rzDbSys rz '/' dbSys
parse var appIns appl '@' install
if cRes \== 'res' then
return err('e}res (not' cRes') expected in res' ix':'i.ix)
if cJob \== 'job' then
return err('e}job (not' cJob') expected in res' ix':'i.ix)
if cId \== 'id' then
return err('e}id (not' cId') expected in res' ix':'i.ix)
if cPgm \== 'pgm' then
return err('e}pgm (not' cPgm') expected in res' ix':'i.ix)
if pgm = '' then
return err('e}pgm missing in res' ix':'i.ix)
if length(cFu) <> 1 then
return err('e}bad cmFun' cFu ix':'i.ix)
if cEr \== '' & cEr \== 'err' then
return err('e}bad errFlag='cEr eMsg ix':'i.ix)
/* no error: we will see missing/spurios errormsg in table
if (cEr == '') <> (res == 0) then
return err('e}res='res 'but err='cEr eMsg ix':'i.ix)
if cEr \== '' & eMsg == '' then ??? till now empty for rc=4
return err('e}no error message in res' ix':'i.ix) */
if length(res) > 4 | res == '' then
call err 'i}bad res =' res 'in' arg(1) res
if res >= 0 & datatype(res, 'n') then
maxCC = max(res, maxCC)
else
maxCC = max(999, maxCC)
eMsg = translate(eMsg, ',', 'FF'x) /* token separator */
if length(eMsg) > 2000 then
eMsg = left(eMsg, 1997)'...'
asUni = "as varchar(6000) ccsid unicode"
call sqlUpdate 3, "update oa1p.tQZ043BindGen" ,
"set result = '"res"', cmJob = '"jobPP"'" ,
", resTst = current timestamp" ,
", cmRes =" cmRes ,
", errMsg = case when length(cast("quote(eMsg, "'") ,
asUni ")) <= 2000 then" quote(eMsg,"'") ,
"else" quote(left(eMsg, 1500)'...', "'") "end" ,
"where genId =" id ,
"and cmPkg = '"pkg"' and genTst = '"tst"'" ,
"and appl = '"appl"' and install = '"install"'" ,
"and rz = '"rz"' and dbSys = '"dbSys"'"
if m.sql.3.updateCount <> 1 then
return err(m.sql.3.updateCount "rows updated for res."ix ,
i.ix)
end
call sqlCommit
call sqlDisConnect
return 'ok,' i.0 'results maxCC' maxCC
endProcedure doRes
/*--- insert pgms into table bindPgm --------------------------------*/
insPgm: procedure expose m.
parse arg appl inst, pgms
do px = 1 to checkPgms(pgms)
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install)",
"values ('"appl"', '"m.pid.px"', '"inst"')"
end
return
endProcedure insPgm
/*--- insert pgms into table bindPgm and bindGen --------------------*/
insPgmGen: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
genSql = "select genTst, pgm, genid from final table(" ,
"insert into oa1p.tQZ043BindGen" ,
"(cmPkg, cmFun, com, cmJob, appl, install, rz, dbSys" ,
",pgm, conTok, genTst)" ,
"values('"cmPkg"', '"f1"', '"com"', '"cmJob"', '"appl"'",
", '"inst"', '"rz"', '?'"
do px = 1 to checkPgms(pgms)
if px=1 then
m.genTst = sql2One(genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"'" ,
", max(current timestamp, value((select max(genTst)" ,
"from oa1p.tqz043BindGen)+ 1e-6 seconds" ,
", current timestamp))))" , bindGen)
else
call sql2One genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"', '"m.genTst"'))",
, bindGen
if m.genTst \== m.bindGen.genTst then
call err 'genTst mismatch' m.genTst '<>' m.bindGen.genTst
m.pid.px.genid = m.bindGen.genId
m.pid.px.genTst = m.bindGen.genTst
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install, id, info)",
"values ('"appl"', '"m.pid.px"', '"inst"'," m.pid.px.genId ,
", 'id" m.pid.px.genId f1 cmPkg"@"m.pid.px.genTst"')"
end
return
endProcedure insPgmGen
checkPgms: procedure expose m.
parse upper arg pgms
px = 0
wx=1
wZ = words(pgms)
do while wx <= wZ
px = px+1
p1 = word(pgms, wx)
wx = wx + 1
if length(p1) < 4 | length(p1) > 8 then
call err 'i}bad program' p1 'in' pgms
if symbol('m.p2x.p1') == 'VAR' then
call err 'i}duplicate program' p1 'in' pgms
m.pid.px = p1
m.p2x.p1 = px
c1 = word(pgms, wx)
if length(c1) = 16 & verify(c1, '00123456789ABCDEF')=0 then do
m.pid.px.conTok = c1
wx = wx+1
end
else
m.pid.px.conTok = left('', 16, 0)
end
if px < 1 then
call err 'i}no programs'
m.pid.0 = px
return m.pid.0
endProcedure checkPgms
/*--- select and insert bind statements,
check programs, update dbSys in bindGen
write to dd bind ---------------------------------------------*/
selWriUpd: procedure expose m.
parse arg qry
call sql2St ,
"select dbSys, pgm, line from final table(" ,
"insert into oa1p.tQZ044BindLine (genId, seq, line)",
"include(dbSys char(4), pgm char(8))",
"select p.Id, b.seq, b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"left join oa1p.tQZ040BindPgm p" ,
"on b.pgm = p.pgm )",
"order by pgm, seq", bb, ":m.dst.dbSys, :m.dst.pgm, :m.dst"
return checkPgmUpdWri(bb, 1)
endProcedure selWriUpd
/*--- select bind statements, check programs,
write to dd bind ---------------------------------------------*/
selWri: procedure expose m.
parse arg qry
call sql2St ,
"select b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"order by pgm, seq", bb, ":m.dst, :m.dst.dbSys, :m.dst.pgm"
return checkPgmUpdWri(bb, 0)
endProcedure selWriUpd
/*--- check programs, if updDbSys then update dbSys in bindGen
write to dd bind ---------------- ----------------------------*/
checkPgmUpdWri: procedure expose m.
parse arg bb, updDbSys
ds = ''
do sx=1 to m.bb.0
p1 = strip(m.bb.sx.pgm)
if p1 = m.sqlNull | m.bb.sx.dbSys = m.sqlNull then
iterate
if symbol('m.p2x.p1') \== 'VAR' then
call err 'fetched pgm' p1 'not in list'
if symbol('p2d.p1') \== 'VAR' then do
px = m.p2x.p1
p2d.p1 = strip(m.bb.sx.dbSys)
if wordPos(p2d.p1, ds) < 1 then
ds = ds p2d.p1
if updDbSys then do
call sqlUpdate 7, "update oa1p.tQZ043BindGen" ,
"set dbSys = '"p2d.p1"'",
"where genId =" m.pid.px.genId ,
"and genTst = '"m.pid.px.genTst"'" ,
"and pgm = '"p1"'"
if m.sql.7.updateCount <> 1 then
call err 'set dbSys updateCount' ,
m.sql.7.updateCount '<> 1'
end
end
else if p2d.p1 \== strip(m.bb.sx.dbSys) then do
if updDbSys then
call err 'pgm p1 multi dbSys' p2d.p1 m.bb.sx.dbSys
end
end
mis = ''
do px=1 to m.pid.0
p1 = m.pid.px
if symbol('p2d.p1') \== 'VAR' then
mis = mis p1
end
if mis \== '' then
call err 'w}nothing generated for programs' mis
call tsoOpen 'BIND', 'W'
call writeDD 'BIND', 'M.bb.'
call tsoClose 'BIND', 'W'
return 'ok' m.pid.0 'programs' m.bb.0 'lines'
endProcedure checkPgmUpdWri
/* rexx */
jobInfo: procedure expose m.
parse arg w
v = 'JOBINFO_'w
if symbol('m.v') == 'VAR' then
return m.v
if m.jobInfo_Ini == 1 then
call err 'no jobInfo for' w
m.jobInfo_Ini = 1
call #jInfo_jobInfo
call mPut 'JOBINFO_TYPE', #JINFO_JTYPE
call mPut 'JOBINFO_NUM' , #JINFO_JNUM
call mPut 'JOBINFO_NAME', #JINFO_JNAME
return jobInfo(w)
endProcedure jobInfo
/*
** >>Jobinfo
*/
#JINFO_JOBINFO:
#JINFO@cvt = storage(10,4) /* FLCCVT-PSA data area */
#JINFO@cvtsname = storage(d2x(c2d(#JINFO@cvt) + 340),8) /* CVTSNAME */
#JINFO@tcbp = storage(d2x(c2d(#JINFO@cvt)),4) /* CVTTCBP */
#JINFO@tcb = storage(d2x(c2d(#JINFO@tcbp)+4),4)
#JINFO@tiot = STORAGE(D2X(C2D(#JINFO@tcb)+12),4) /* Get TIOT address */
#JINFO@jscb = STORAGE(D2X(C2D(#JINFO@tcb)+180),4)
#JINFO@ssib = STORAGE(D2X(C2D(#JINFO@jscb)+316),4)
#JINFO@jinfo = STORAGE(D2X(C2D(#JINFO@tiot)),24)
#JINFO_JTYPE = STORAGE(D2X(C2D(#JINFO@ssib)+12),3)
#JINFO_JNUM = strip(storage(D2X(C2D(#JINFO@ssib)+15),5),l,0)
#JINFO_JNAME = substr(#JINFO@jinfo,1,8)
#JINFO_JPROC = substr(#JINFO@jinfo,9,8)
#JINFO_JPROCSTEP = substr(#JINFO@jinfo,17,8)
#JINFO_CVTSNAME = #JINFO@cvtsname /* system name */
drop #JINFO@cvt #JINFO@tcbp #JINFO@tcb #JINFO@tiot #JINFO@jscb
drop #JINFO@ssib #JINFO@jinfo #JINFO@cvtsname
return
#JINFO_DROP:
DROP #JINFO_JTYPE #JINFO_JNUM #JINFO_JNAME #JINFO_JPROC #JINFO_JPROCSTEP
return
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
m.sql.cx.fetchCode = cd
st = 'SQL.'cx'.COL'
call sqlRemVars st
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
return
end
m.sql.cx.fetchVars = ''
vrs = ''
sNu = ''
if abbrev(src, '?') then do
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end
end
else if src <> '' then do kx=1 to words(src)
cn = word(src, kx)
call sqlRexxAddVar cn, 0, m.sql.cx.d.kx.sqlType // 2
end
else do kx=1 to m.sql.cx.d.sqlD
call sqlRexxAddVar m.sql.cx.d.kx.sqlName, 1 ,
, m.sql.cx.d.kx.sqlType // 2
end
m.sql.cx.fetchVars = substr(vrs, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
sqlCol2kx: procedure expose m.
parse arg cx, nm
if symbol('M.SQL.CX.COL.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col.nm
if m.sql.cx.col.kx \== nm then
call err 'sqlCol2kx' nm '==>' kx 'but' m.sql.cx.col.kx
return kx
endProcedure sqlCol2kx
sqlRemVars: procedure expose m.
parse arg st
if symbol('m.st.0') == 'VAR' then do
do sx=1 to m.st.0
nm = m.st.sx
drop m.st.nm m.st.sx
end
end
m.st.0 = 0
return
endProcedure sqlRemVars
sqlAddVar: procedure expose m.
parse arg st, sNa, nicify
sx = m.st.0 + 1
if 1 | nicify then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('m.st.sNa') == 'VAR' then
sNa = 'COL'sx
end
m.st.0 = sx
m.st.sx = sNa
m.st.sNa = sx
return sNa
endProcedure sqlAddVar
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 1 then do
hahi = m.sql_HaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql_HaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet == '*' then
return m.tso_rc
else if wordPos(m.tso_rc, ggRet) > 0 then
return m.tso_rc
else
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call saySt(splitNl(err, 'tsoAlloc rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call saySt(splitNl(err, 'rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csmNull begin **************************************************
pseudo csm Modul, to avoid missing modules error from rexx compiler
***********************************************************************/
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
call err 'csmAlloc not copied into this rexx'
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
call err 'csmLikeAtts not copied into this rexx'
/* copy csmNull end ***************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
call adrTso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(BINDDB) cre=2014-04-02 mod=2016-04-22-13.45.16 A540769 ---
/* REXX ----------------------------------------------------------------
bindDB: bind Interface for DB2
synopsis: bindDB B appl? install? rz (pgm conTok?)+
bindDB D appl? install? pgm+
bindDB E dBind dRes? dErr?
bindDB S dRes cmRes
bindDB R appl? install? rz pgm+
bindDB any bindCMN statement
b -> pgm, d -> dbp, r -> rebind, e -> exe, s -> res
bindDB calls bindCMN and shows the output in a view session
the 3-letter statments are passed unchanged to bindCM
in short statements missing parameters are filled with defaults
parameters are described under bindCMN, except:
dBind: DSN with (generated) bind statements
dRes : DSN for Result
dErr : DSN for errReport
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
parse upper arg mFun mRest
m.mArg = space(arg(1), 1)
m.inlineCMN = 1 /* 1= call dbp in diesem rexx
0= call dbp in rexx bindCMN (zum Testen|) */
m.sql_dbSys = ''
call errReset 'hi', "call errReset 'hi'" ,
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end"
if mFun == '' then do
if 0 then
exit errHelp('no input')
parse upper value 'PGM abc4567890 f -t jobTest' ,
'alab 01.01.14 rzy yavmur 839695E39692F0F1' ,
'pgm2 839695E39692F0F2' with mFun mRest
parse upper value 'e A540769.WK.REXX(BINDteb3)' with mFun mRest
parse upper value 's A540769.WK.TEXV(bindRes3) 8' with mFun mRest
parse upper value 's WOK.U0000.P0.RZ4AKT.HK.RQ2DBR.RES.D151211',
with mFun mRest
end
if mFun == 'B' then
call callCmn 'PGM' argExp(1, mRest)
else if mFun == 'D' then
call callCmn 'DBP' argExp(0, mRest)
else if mFun == 'E' then do
/* call dsnAlloc 'dd(dbrmLib) CMN.DIV.P0.DB2J.#000223.DBR' */
call dsnAlloc 'dd(dbrmLib) A540769.WK.DBRM'
call callCmn 'EXE' mRest
call tsoFree dbrmLib
end
else if mFun == 'R' then
call callCmn 'REBIND' argExp(1, mRest)
else if mFun == 'S' then do
if words(mRest) == 1 then
mRest = mRest 0
call callCmn 'RES' mRest
end
else
call callCmn mFun mRest
exit 0
callCmn: procedure expose m.
parse arg fun rest
fr = ''
if wordPos(fun, 'DBP PGM REBIND') > 0 then do
showDD = 'BIND'
call dsnAlloc 'dd(bind) new ::f'
end
else if fun = 'EXE' then do
parse var rest in out err
if in = '' then
return errHelp('i}no input for Exe:' fun rest)
fr = fr word(dsnAlloc( 'dd(bind)' in), 2)
if out = '' then
call dsnAlloc 'dd(bindRes) new ::v2500'
else
call dsnAlloc 'dd(bindRes)' out '::v2500'
if err = '' then
call dsnAlloc 'dd(bindErr) new ::f'
else
call dsnAlloc 'dd(bindErr)' err '::f'
showDD = 'BINDRES BINDERR'
end
else if fun = 'RES' then do
if words(rest) <> 2 then
return errHelp('i}bad input for Res:' fun rest)
fr = fr word(dsnAlloc( 'dd(bindRes)' word(rest, 1)), 2)
rest = word(rest, 2)
showDD = ''
end
else
return errHelp('i}bad fun' fun 'in:' fun rest)
trace ?r
if m.inlineCMN then
res = cmnWork(fun, rest)
else
res = bindcmn(fun rest)
doShow = showDD \== '' & (abbrev(res, 'ok') | fun = 'EXE')
if \ (m.inlineCMN & doShow) then
say fun 'res =' res
call tsoFree fr
if doShow then do sx=1 to words(showDD)
dd1 = word(showDD, sx)
call adrIsp "LMINIT DATAID(lmmId) ddName("dd1") ENQ(SHRW)"
eRc = adrIsp("edit dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
end
if showDD \== '' then
call tsoFree showDD
if \ abbrev(res, 'ok') then
call err 'e}'res
else if doShow & ((eRc \== 0 & eRc \== 4) | lRc \== 0) then
call err 'e}'m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure callCmn
argExp: procedure expose m.
parse arg isLo, args
res = argEx2(isLo, args)
if \ m.inlineCMN then
if space(res, 1) <> space(args, 1) then
say 'expanding' args '==>' res
return res
endProcedure argExp
argEx2: procedure expose m.
parse arg isLo, w1 w2 rest
if appl = '' then
call err 'i}no arguments'
if isLo then
h = userid() 't' left('bindDB:'translate(m.mArg, '-',' '), 20) ,
mvsvar('symdef', 'jobname')' '
else
h = ''
i = anaInst(w1)
if i \== '' then
return h'appl' i w2 rest
i = anaInst(w2)
if i \== '' then
return h || w1 i rest
i = anaInst(date('s'))
if length(w1) == 4 then
return h || w1 i w2 rest
else
return h'appl' i w1 w2 rest
endProcedure argEx2
/* |||| copy bindCMN und adrISP ||||||||||||||||||||||||||||||||||||||*/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* REXX ----------------------------------------------------------------
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
m.sql_dbSys = ''
call errReset "hi", "call errReset 'hi'" ,
"; call errSay 'f}'ggTxt; call errCleanup",
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end" ,
"; exit 'error' ggTxt"
parse upper arg fun rest
/*%SYSDATE */
/*%SYSTIME */
say "BINDCMN Vers:" SYSDATE"/"SYSTIME "/Function:" FUN "/" REST
if wordPos(fun, 'DBP PGM EXE RES') < 1 then
return errHelp('i}bad fun' fun 'in:' fun rest)
exit cmnWork(fun, rest)
cmnWork: procedure expose m.
parse arg fun, rest
if pos('?', fun rest) > 0 | fun = '' then
exit help()
if fun <> 'EXE' then
call sqlConnect 'DP4G'
if fun == 'PGM' then
res = doPGM(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'REBIND' then
res = doRebind(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'DBP' then
res = doDBP(anaAI(rest))
else if fun == 'EXE' then
res = doExe()
else if fun == 'RES' then
res = doRes(rest)
else
return errHelp('i}bad args:' fun rest)
if m.sql_dbSys <> '' then
call sqlDisconnect
return res
endProcedure cmnWork
exit 0
anaAI: procedure expose m.
parse arg appl inst rest
if appl = '' then
call err 'i}no arguments'
if rest = '' then
call err 'i}no program:' appl inst rest
i = anaInst(inst)
if i == '' then
call err 'i}bad installDate' inst 'in:' appl inst rest
if length(appl) <> 4 then
call err 'i}bad appl' appl 'in:' appl inst rest
return appl i rest
endProcedure anaAI
ana7: procedure expose m.
parse arg args
parse arg cmPkg f1 com cmJob appl inst rz rest
if length(cmPkg) > 10 then
call err 'i}bad cmPkg' cmPkg 'args:' args
if length(f1) <> 1 then
call err 'i}bad cmFun' f1 'args:' args
if length(com) > 20 then
call err 'i}bad com' com 'args:' args
if length(cmJob) > 20 then
call err 'i}bad cmJob' cmJob 'args:' args
i = word(anaAI(appl inst 'x'), 2)
if length(rz) <> 3 | \ abbrev(rz, 'R') then
call err 'i}bad rz' rz 'args:' args
return cmPkg f1 com cmJob appl i rz rest
endProcedure ana6
anaInst: procedure expose m.
parse arg inst
today = translate('78.56.1234', date('s'), '12345678')
i0 = translate(inst, '000000000', '123456789')
if i0 == '00000000' then
return translate('78.56.1234', inst, '12345678')
else if i0 == '0000' then
return translate('34.12', inst, '1234')substr(today, 6)
else if i0 == '00.00' then
return inst || substr(today, 6)
else if i0 == '00.00.00' then
return left(inst,6)substr(today, 7, 2)right(inst, 2)
else if i0 == '00.00.0000' then
return inst
else
return ''
endProcedure anaInst
doPGM: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindRz" ,
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doPGM
doRebind: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040Rebind",
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doRebind
doDBP: procedure expose m.
parse arg appl inst pgms
call insPgm appl inst, pgms
res = selWri( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindDBP")
call sqlCommit
call sqlDisConnect
return res
endProcedure doDBP
doExe: procedure expose m.
call tsoOpen 'BIND', 'R'
call readDD 'BIND', i., '*'
call tsoClose 'BIND'
ox = 0
ex = 0
ey = ex
ccMax = 0
ccId = 0
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
str = 'b'
do ix = 1 to i.0 /* each line */
/* concat one command */
li = strip(doExeComm(i.ix), str)
if iCmd = '' then
ey = ex + 2
else
ey = ey + 1
e.ey = li
if right(li, 1) == '-' then do
iCmd = iCmd || left(li, length(li)-1)
str = 't'
iterate
end
else if right(li, 1) == '+' then do
iCmd = iCmd || left(li, length(li)-1)
str = 'b'
iterate
end
else do
iCmd = iCmd || li
end
/* we have one command in iCmd */
str = 'b' /* for next cmd */
if iCmd = '' then
iterate
if iFirst == '' then do /* dsn command */
iFirst = strip(iCmd)
iCmd = ''
iterate /* look next bind */
end
if translate(iCmd) = 'END' then do /* end of program */
ox = ox+1 /* result for program */
o.ox = 'res' ccId,
'job' strip(jobInfo(name))'#'strip(jobInfo(num)) ,
'id' m.doExe.iId 'pgm' m.doExe.iPgm
if ccId > 0 then
if length(eM) <= 2000 then
o.ox = o.ox 'err' eM
else
o.ox = o.ox 'err' left(eM, 1997)'...'
ccMax = max(ccMax, ccId)
ccId = 0 /* reset variables */
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
iterate
end
/* we got one bind in iCmd */
do while queued() > 0 to /* clear input queue */
parse pull pOld
say 'err pulled:' pOld
ccMax = max(99, ccMax)
end
say iFirst '=>' space(iCmd, 1) /* execute dsn bind end */
queue iCmd
queue 'end'
cc = adrTso(iFirst, '*')
do tx=1 to m.tso_trap.0 /* say output of bind */
say m.tso_trap.tx
end
cc2 = cc
if cc < 0 | \ datatype(cc, 'n') then
cc2 = 999
if cc2 > 0 then do
ez = ex+1 /* write whole command to err */
e.ez = iFirst
ex = ey
end
eM = doExeMsg(eM, cc2 ccId, iFirst, iCmd)
ccId = max(ccId, cc2)
say e.actMsg
iCmd = '' /* end one bind */
end /* each line */
if iCmd \== '' | iFirst \== '' then
call err 'fileEnd but iCmd='iCmd', iFirst='iFirst
if ccId \== 0 | eM \== '' then
call err 'fileEnd but ccId='ccId', eM='eM
if ex = 0 then do
ex = ex + 1
e.ex = 'ccMax =' ccMax
end
call tsoOpen 'BINDRES', 'W'
call writeDD 'BINDRES', 'o.', ox
call tsoClose 'bindRes'
call tsoOpen 'BINDErr', 'W'
call writeDD 'BINDErr', 'e.', ex
call tsoClose 'BINDErr'
if ccMax <= 4 then
return 'ok ccMax' ccMax 'for exe'
else
return 'err ccMax' ccMax 'for exe'
endProcedure doExe
doExeMsg: procedure expose m. e. ex
parse arg eM, cc2 ccId, iFirst, iCmd
m0 = sysvar(sysNode)
cx = pos('(', iFirst)
if cx > 0 & right(iFirst, 1) == ')' then
m0 = m0'/'substr(iFirst, cx+1, length(iFirst)-cx-1)
else
m0 = m0'/'iFirst
uCmd = translate(iCmd)
cx = pos('PACKAGE(', uCmd)
cy = pos('MEMBER(', uCmd)
if cx > 0 & cy > 0 then do
col = word(substr(iCmd, cx+8), 1)
if right(col, 1) == ')' then
col = left(col, length(col)-1)
mbr = word(substr(iCmd, cy+7), 1)
if right(mbr, 1) == ')' then
mbr = left(mbr, length(mbr)-1)
sCmd = left(iCmd, min(cx, cy)-1) col'.'mbr
end
else do
sCmd = iCmd
end
if length(m0) > 30 then
actM = left(m0, 27)'...' sCmd
else
actM = m0 sCmd
if cc2 > 4 | cc2 < 0 then
e.actMsg = strip(left('error cc='cc2 actM, 80))
else if cc2 > 0 then
e.actMsg = strip(left('warning cc='cc2 actM, 80))
else do
e.actMsg = strip(left('ok cc='cc2 actM, 80))
ex = ex + 1
e.ex = e.actMsg
return eM
end
actM = ''
do tx=1 to m.tso_trap.0
t1 = m.tso_trap.tx
ex = ex + 1
e.ex = left(t1, 80)
if wordPos(word(t1, 1), 'DSNX200I') > 0 then
iterate
j = space(t1, 1)
if j == 'USING CMNBATCH AUTHORITY' ,
| j == 'PLAN=(NOT APPLICABLE)' ,
| j == 'DBRM='m.doExe.iPgm then
iterate
cx = pos('=', j)
if cx > 1 then
if pos('='left(j, cx),
, '=SQLSTATE=CSECT NAME=RDS CODE=') > 0 then
iterate
actM = actM' 'j
end
if eM == '' then
return m0':' actM';'
else if cc2 > ccId then
return m0':' actM';' eM
else
return eM m0':' actM';'
endProcedure doExeMsg
doExeComm: procedure expose m.
parse arg src
res = ''
cy = -1
do forever
cx = pos('/*', src, cy+2)
if cx < 1 then
return res || substr(src, cy+2)
res = res || substr(src, cy+2, cx-cy-2)
cy = pos('*/', src, cx+2)
if cy < 1 then
com = strip(substr(src, cx+2))
else
com = strip(substr(src, cx+2, cy-cx-2))
say '/*' com
w1 = word(com, 1)
if w1 == 'beginRzPgm' then
m.doExe.iPgm = strip(subword(com, 2))
else if w1 == 'id' then
m.doExe.iId = strip(subword(com, 2))
if cy < 1 then
return res
end
endProcedure doExeComm
doRes: procedure expose m.
parse arg cmRes
if ^ (cmRes == 0 | cmRes == 8) then
call err 'cmRes bad cmRes =' cmRes
call readDD bindRes, i., '*'
call tsoClose bindRes
maxCC = 0
if i.0 < 1 then
return err('e}no lines in dd bindRes')
do ix=1 to i.0
parse var i.ix cRes res cJob jobPP cId id cFu pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
if length cFu <> 1 & pos('@', cFu) > 0 then do
cFu = ' '
parse var i.ix cRes res cJob jobPP cId id pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
end
parse var pkgTst pkg '@' tst
parse var rzDbSys rz '/' dbSys
parse var appIns appl '@' install
if cRes \== 'res' then
return err('e}res (not' cRes') expected in res' ix':'i.ix)
if cJob \== 'job' then
return err('e}job (not' cJob') expected in res' ix':'i.ix)
if cId \== 'id' then
return err('e}id (not' cId') expected in res' ix':'i.ix)
if cPgm \== 'pgm' then
return err('e}pgm (not' cPgm') expected in res' ix':'i.ix)
if pgm = '' then
return err('e}pgm missing in res' ix':'i.ix)
if length(cFu) <> 1 then
return err('e}bad cmFun' cFu ix':'i.ix)
if cEr \== '' & cEr \== 'err' then
return err('e}bad errFlag='cEr eMsg ix':'i.ix)
/* no error: we will see missing/spurios errormsg in table
if (cEr == '') <> (res == 0) then
return err('e}res='res 'but err='cEr eMsg ix':'i.ix)
if cEr \== '' & eMsg == '' then ??? till now empty for rc=4
return err('e}no error message in res' ix':'i.ix) */
if length(res) > 4 | res == '' then
call err 'i}bad res =' res 'in' arg(1) res
if res >= 0 & datatype(res, 'n') then
maxCC = max(res, maxCC)
else
maxCC = max(999, maxCC)
eMsg = translate(eMsg, ',', 'FF'x) /* token separator */
if length(eMsg) > 2000 then
eMsg = left(eMsg, 1997)'...'
asUni = "as varchar(6000) ccsid unicode"
call sqlUpdate 3, "update oa1p.tQZ043BindGen" ,
"set result = '"res"', cmJob = '"jobPP"'" ,
", resTst = current timestamp" ,
", cmRes =" cmRes ,
", errMsg = case when length(cast("quote(eMsg, "'") ,
asUni ")) <= 2000 then" quote(eMsg,"'") ,
"else" quote(left(eMsg, 1500)'...', "'") "end" ,
"where genId =" id ,
"and cmPkg = '"pkg"' and genTst = '"tst"'" ,
"and appl = '"appl"' and install = '"install"'" ,
"and rz = '"rz"' and dbSys = '"dbSys"'"
if m.sql.3.updateCount <> 1 then
return err(m.sql.3.updateCount "rows updated for res."ix ,
i.ix)
end
call sqlCommit
call sqlDisConnect
return 'ok,' i.0 'results maxCC' maxCC
endProcedure doRes
/*--- insert pgms into table bindPgm --------------------------------*/
insPgm: procedure expose m.
parse arg appl inst, pgms
do px = 1 to checkPgms(pgms)
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install)",
"values ('"appl"', '"m.pid.px"', '"inst"')"
end
return
endProcedure insPgm
/*--- insert pgms into table bindPgm and bindGen --------------------*/
insPgmGen: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
genSql = "select genTst, pgm, genid from final table(" ,
"insert into oa1p.tQZ043BindGen" ,
"(cmPkg, cmFun, com, cmJob, appl, install, rz, dbSys" ,
",pgm, conTok, genTst)" ,
"values('"cmPkg"', '"f1"', '"com"', '"cmJob"', '"appl"'",
", '"inst"', '"rz"', '?'"
do px = 1 to checkPgms(pgms)
if px=1 then
m.genTst = sql2One(genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"'" ,
", max(current timestamp, value((select max(genTst)" ,
"from oa1p.tqz043BindGen)+ 1e-6 seconds" ,
", current timestamp))))" , bindGen)
else
call sql2One genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"', '"m.genTst"'))",
, bindGen
if m.genTst \== m.bindGen.genTst then
call err 'genTst mismatch' m.genTst '<>' m.bindGen.genTst
m.pid.px.genid = m.bindGen.genId
m.pid.px.genTst = m.bindGen.genTst
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install, id, info)",
"values ('"appl"', '"m.pid.px"', '"inst"'," m.pid.px.genId ,
", 'id" m.pid.px.genId f1 cmPkg"@"m.pid.px.genTst"')"
end
return
endProcedure insPgmGen
checkPgms: procedure expose m.
parse upper arg pgms
px = 0
wx=1
wZ = words(pgms)
do while wx <= wZ
px = px+1
p1 = word(pgms, wx)
wx = wx + 1
if length(p1) < 4 | length(p1) > 8 then
call err 'i}bad program' p1 'in' pgms
if symbol('m.p2x.p1') == 'VAR' then
call err 'i}duplicate program' p1 'in' pgms
m.pid.px = p1
m.p2x.p1 = px
c1 = word(pgms, wx)
if length(c1) = 16 & verify(c1, '00123456789ABCDEF')=0 then do
m.pid.px.conTok = c1
wx = wx+1
end
else
m.pid.px.conTok = left('', 16, 0)
end
if px < 1 then
call err 'i}no programs'
m.pid.0 = px
return m.pid.0
endProcedure checkPgms
/*--- select and insert bind statements,
check programs, update dbSys in bindGen
write to dd bind ---------------------------------------------*/
selWriUpd: procedure expose m.
parse arg qry
call sql2St ,
"select dbSys, pgm, line from final table(" ,
"insert into oa1p.tQZ044BindLine (genId, seq, line)",
"include(dbSys char(4), pgm char(8))",
"select p.Id, b.seq, b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"left join oa1p.tQZ040BindPgm p" ,
"on b.pgm = p.pgm )",
"order by pgm, seq", bb, ":m.dst.dbSys, :m.dst.pgm, :m.dst"
return checkPgmUpdWri(bb, 1)
endProcedure selWriUpd
/*--- select bind statements, check programs,
write to dd bind ---------------------------------------------*/
selWri: procedure expose m.
parse arg qry
call sql2St ,
"select b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"order by pgm, seq", bb, ":m.dst, :m.dst.dbSys, :m.dst.pgm"
return checkPgmUpdWri(bb, 0)
endProcedure selWriUpd
/*--- check programs, if updDbSys then update dbSys in bindGen
write to dd bind ---------------- ----------------------------*/
checkPgmUpdWri: procedure expose m.
parse arg bb, updDbSys
ds = ''
do sx=1 to m.bb.0
p1 = strip(m.bb.sx.pgm)
if p1 = m.sqlNull | m.bb.sx.dbSys = m.sqlNull then
iterate
if symbol('m.p2x.p1') \== 'VAR' then
call err 'fetched pgm' p1 'not in list'
if symbol('p2d.p1') \== 'VAR' then do
px = m.p2x.p1
p2d.p1 = strip(m.bb.sx.dbSys)
if wordPos(p2d.p1, ds) < 1 then
ds = ds p2d.p1
if updDbSys then do
call sqlUpdate 7, "update oa1p.tQZ043BindGen" ,
"set dbSys = '"p2d.p1"'",
"where genId =" m.pid.px.genId ,
"and genTst = '"m.pid.px.genTst"'" ,
"and pgm = '"p1"'"
if m.sql.7.updateCount <> 1 then
call err 'set dbSys updateCount' ,
m.sql.7.updateCount '<> 1'
end
end
else if p2d.p1 \== strip(m.bb.sx.dbSys) then do
if updDbSys then
call err 'pgm p1 multi dbSys' p2d.p1 m.bb.sx.dbSys
end
end
mis = ''
do px=1 to m.pid.0
p1 = m.pid.px
if symbol('p2d.p1') \== 'VAR' then
mis = mis p1
end
if mis \== '' then
call err 'w}nothing generated for programs' mis
call tsoOpen 'BIND', 'W'
call writeDD 'BIND', 'M.bb.'
call tsoClose 'BIND', 'W'
return 'ok' m.pid.0 'programs' m.bb.0 'lines'
endProcedure checkPgmUpdWri
/* rexx */
jobInfo: procedure expose m.
parse arg w
v = 'JOBINFO_'w
if symbol('m.v') == 'VAR' then
return m.v
if m.jobInfo_Ini == 1 then
call err 'no jobInfo for' w
m.jobInfo_Ini = 1
call #jInfo_jobInfo
call mPut 'JOBINFO_TYPE', #JINFO_JTYPE
call mPut 'JOBINFO_NUM' , #JINFO_JNUM
call mPut 'JOBINFO_NAME', #JINFO_JNAME
return jobInfo(w)
endProcedure jobInfo
/*
** >>Jobinfo
*/
#JINFO_JOBINFO:
#JINFO@cvt = storage(10,4) /* FLCCVT-PSA data area */
#JINFO@cvtsname = storage(d2x(c2d(#JINFO@cvt) + 340),8) /* CVTSNAME */
#JINFO@tcbp = storage(d2x(c2d(#JINFO@cvt)),4) /* CVTTCBP */
#JINFO@tcb = storage(d2x(c2d(#JINFO@tcbp)+4),4)
#JINFO@tiot = STORAGE(D2X(C2D(#JINFO@tcb)+12),4) /* Get TIOT address */
#JINFO@jscb = STORAGE(D2X(C2D(#JINFO@tcb)+180),4)
#JINFO@ssib = STORAGE(D2X(C2D(#JINFO@jscb)+316),4)
#JINFO@jinfo = STORAGE(D2X(C2D(#JINFO@tiot)),24)
#JINFO_JTYPE = STORAGE(D2X(C2D(#JINFO@ssib)+12),3)
#JINFO_JNUM = strip(storage(D2X(C2D(#JINFO@ssib)+15),5),l,0)
#JINFO_JNAME = substr(#JINFO@jinfo,1,8)
#JINFO_JPROC = substr(#JINFO@jinfo,9,8)
#JINFO_JPROCSTEP = substr(#JINFO@jinfo,17,8)
#JINFO_CVTSNAME = #JINFO@cvtsname /* system name */
drop #JINFO@cvt #JINFO@tcbp #JINFO@tcb #JINFO@tiot #JINFO@jscb
drop #JINFO@ssib #JINFO@jinfo #JINFO@cvtsname
return
#JINFO_DROP:
DROP #JINFO_JTYPE #JINFO_JNUM #JINFO_JNAME #JINFO_JPROC #JINFO_JPROCSTEP
return
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
m.sql.cx.fetchCode = cd
st = 'SQL.'cx'.COL'
call sqlRemVars st
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
return
end
m.sql.cx.fetchVars = ''
vrs = ''
sNu = ''
if abbrev(src, '?') then do
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end
end
else if src <> '' then do kx=1 to words(src)
cn = word(src, kx)
call sqlRexxAddVar cn, 0, m.sql.cx.d.kx.sqlType // 2
end
else do kx=1 to m.sql.cx.d.sqlD
call sqlRexxAddVar m.sql.cx.d.kx.sqlName, 1 ,
, m.sql.cx.d.kx.sqlType // 2
end
m.sql.cx.fetchVars = substr(vrs, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
sqlCol2kx: procedure expose m.
parse arg cx, nm
if symbol('M.SQL.CX.COL.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col.nm
if m.sql.cx.col.kx \== nm then
call err 'sqlCol2kx' nm '==>' kx 'but' m.sql.cx.col.kx
return kx
endProcedure sqlCol2kx
sqlRemVars: procedure expose m.
parse arg st
if symbol('m.st.0') == 'VAR' then do
do sx=1 to m.st.0
nm = m.st.sx
drop m.st.nm m.st.sx
end
end
m.st.0 = 0
return
endProcedure sqlRemVars
sqlAddVar: procedure expose m.
parse arg st, sNa, nicify
sx = m.st.0 + 1
if 1 | nicify then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('m.st.sNa') == 'VAR' then
sNa = 'COL'sx
end
m.st.0 = sx
m.st.sx = sNa
m.st.sNa = sx
return sNa
endProcedure sqlAddVar
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 1 then do
hahi = m.sql_HaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql_HaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet == '*' then
return m.tso_rc
else if wordPos(m.tso_rc, ggRet) > 0 then
return m.tso_rc
else
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call saySt(splitNl(err, 'tsoAlloc rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call saySt(splitNl(err, 'rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csmNull begin **************************************************
pseudo csm Modul, to avoid missing modules error from rexx compiler
***********************************************************************/
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
call err 'csmAlloc not copied into this rexx'
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
call err 'csmLikeAtts not copied into this rexx'
/* copy csmNull end ***************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
call adrTso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(BINDTEB1) cre=2014-09-03 mod=2014-09-03-16.15.53 A540769 ---
DSN S(DP4G)
BIND PACKAGE(QZ) -
OWNER(CMNBATCH) -
QUALIFIER(OA1A) -
MEMBER(QZNZGFM) -
CURRENTDATA(NO) -
DEGREE(1) -
DYNAMICRULES(BIND) -
EXPLAIN(YES) -
FLAG(I) -
ISOLATION(CS) -
SQLERROR(NOPACKAGE) -
VALIDATE(BIND) -
ACTION(REPLACE)
END
}¢--- A540769.WK.REXX(BINDTEB2) cre=2014-09-04 mod=2014-09-04-10.37.12 A540769 ---
/* beginRzPgm RZZ/DE0G appl@04.09.2014 QZPLB
/* 1 binds in 1 locations
/* id 70 t A540769@2014-09-04-10.35.48.221954
dsn system(DP4G)
bind package(QZ) -
member(QZPLB) -
qualifier(OA1P) -
OWNER(CMNBATCH) -
ISOLATION(CS) -
DEGREE(1) -
DYNAMICRULES(BIND) -
VALIDATE(BIND) -
EXPLAIN(YES) -
FLAG(I) -
sqlError(noPackage) -
action(replace) -
/* end RZZ/DE0G appl@04.09.2014 .QZ.QZPLB
end
}¢--- A540769.WK.REXX(BINDTEB3) cre=2014-09-04 mod=2014-09-04-11.41.51 A540769 ---
/* beginRzPgm RZX/DE0G appl@04.09.2014 YAVVDPS
/* 3 binds in 1 locations
/* id 71 t A540769@2014-09-04-10.38.48.211138
dsn system(DP4G)
bind package(AV02) -
member(QZPLX) -
qualifier(OA1P02) -
OWNER(CMNBATCH) -
ISOLATION(CS) -
DEGREE(1) -
DYNAMICRULES(BIND) -
VALIDATE(BIND) -
EXPLAIN(YES) -
FLAG(I) -
sqlError(noPackage) -
action(replace) -
/* end RZX/DE0G appl@04.09.2014 .AV02.YAVVDPS
bind package(AV01) -
member(YAVVDPS) -
qualifier(OA1P01) -
OWNER(CMNBATCH) -
ISOLATION(CS) -
DEGREE(1) -
DYNAMICRULES(BIND) -
VALIDATE(BIND) -
EXPLAIN(YES) -
FLAG(I) -
sqlError(noPackage) -
action(replace) -
/* end RZX/DE0G appl@04.09.2014 .AV01.YAVVDPS
bind package(AV03) -
member(QZPLB) -
qualifier(OA1P) -
OWNER(CMNBATCH) -
ISOLATION(CS) -
DEGREE(1) -
DYNAMICRULES(BIND) -
VALIDATE(BIND) -
EXPLAIN(YES) -
FLAG(I) -
sqlError(noPackage) -
action(replace) -
/* end RZX/DE0G appl@04.09.2014 .AV03.YAVVDPS
end
/* beginRzPgm RZZ/DE0G appl@04.09.2014 QZPLB
/* 1 binds in 1 locations
/* id 70 t A540769@2014-09-04-10.35.48.221954
dsn system(DP4G)
bind package(QZ) -
member(QZPLB) -
qualifier(OA1P) -
OWNER(CMNBATCH) -
ISOLATION(CS) -
DEGREE(1) -
DYNAMICRULES(BIND) -
VALIDATE(BIND) -
EXPLAIN(YES) -
FLAG(I) -
sqlError(noPackage) -
action(replace) -
/* end RZZ/DE0G appl@04.09.2014 .QZ.QZPLB
end
}¢--- A540769.WK.REXX(CADB2) cre=2007-11-09 mod=2016-04-29-10.04.42 A540769 ----
/* rexx ----------------------------------------------------- 29. 4. 16
caDb2: start the ca tools with cs Libraries
options d: debug, say which libraries
w: with test and personal work libs (wk.rexx ...)
t: with test libs (dsn.cadb2.cs.execTst ...)
: with prod libs (dsn.cadb2.cs.exec)
1 2 3 4: with this alias (default P0)
---------------------------------------------------------------------*/
parse upper arg arg
rz="RZ"MVSVAR('SYMDEF','rzid')
libs = "'dsn.cadb2.cs.exec'"
alias = 'P0'
if arg <> '' then do
if pos('?', arg) > 0 then
return help()
if pos('T', arg) > 0 then
libs = "'dsn.cadb2.cs.exectst'" libs
else if pos('W', arg) > 0 then
libs = "'"userid()".WK.REXX' 'dsn.cadb2.cs.exectst'" libs
vx = verify(arg, '0123456789' ,'m')
if vx > 0 then
alias = 'P'substr(arg, vx, 1)
say 'cadb2 alias='alias', libs='libs
end
pref = "DSN.CADB2."rz"."alias
clist = pref".CDBACLS0"
ADDRESS tso "ALTLIB ACTIVATE APPLICATION(EXEC) DATASET("libs") uncond"
ADDRESS tso "ALTLIB ACTIVATE APPLICATION(CLIST)" ,
"DATASET('"clist"') uncond"
call dRep 'U *'
ADDRESS "ISPEXEC" "SELECT MODE(FSCR) NEWAPPL(CA) passlib",
"CMD(EX '"clist"(RSPMAIN)' 'HIGHLVL("pref")'"
ADDRESS tso "ALTLIB deACTIVATE APPLICATION(EXEC)"
ADDRESS tso "ALTLIB deACTIVATE APPLICATION(CLIST)"
exit 0
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(CADB3) cre=2012-11-14 mod=2012-11-14-13.26.12 A540769 ----
/* rexx ---------------------------------------------------------------
caDb2: start the ca tools with cs Libraries
options d: debug, say which libraries
w: with test and personal work libs (wk.rexx ...)
t: with test libs (dsn.cadb2.cs.execTst ...)
: with prod libs (dsn.cadb2.cs.exec)
---------------------------------------------------------------------*/
parse upper arg arg
libs = "'dsn.cadb2.cs.exec'"
if arg == '' & userid() == 'A540769' then
arg = 'W'
if pos('W', arg) > 0 then
libs = "'"userid()".WK.REXX' 'dsn.cadb2.cs.exectst'" libs
else if pos('T', arg) > 0 then
libs = "'dsn.cadb2.cs.exectst'" libs
if pos('D', arg) > 0 then
say 'caDb2 altLib' libs
ADDRESS tso "ALTLIB ACTIVATE APPLICATION(EXEC) DATASET("libs") uncond"
ADDRESS 'ISPEXEC' 'SELECT MODE(FSCR) NEWAPPL(CA) passlib',
"CMD(EX 'DSN.CADB2.RZ1.P0.CDBACLS0(RSPMAIN)')"
ADDRESS tso "ALTLIB deACTIVATE APPLICATION(EXEC)"
}¢--- A540769.WK.REXX(CASQL) cre=2012-08-27 mod=2012-08-27-17.41.08 A540769 ----
PROC 0 SSID() /* reserved - DB2 Subsystem ID */ -
SUFFIX() /* reserved - Global Parmlib Suffix */ -
PARMLIB() /* reserved - Parmlib dsname or ddname */ -
RECURS(NO) /* reserved */
/*********************************************************************/
/* ALL RIGHTS RESERVED */
/* COPYRIGHT 2001 COMPUTER ASSOCIATES INTERNATIONAL */
/*********************************************************************/
/* */
/* System : ISQL */
/* */
/* Abstract : ISPF EDIT <==> ISQL INTERFACE */
/* */
/* Function : Jump into ISQL from an ISPF edit session. */
/* */
/* Usage : Mark the first and last lines of the SQL statement */
/* using the E or EE/EE line commands, enter SQL on the */
/* command line, and press enter. */
/* */
/* How this clist works : */
/* */
/* It is no longer necessary (or recommended) to */
/* manually allocate runtime libraries in any clist */
/* such as this one. All allocations are now handled */
/* by the CA-DB2 Tools start-up clists (RSPDEF, */
/* RSPINIT, and RSPFREE), using information in the */
/* CA-DB2 Tools parmlib_dataset. */
/* */
/* This design gives customers the ability to define */
/* multiple runtime environments, which are selectable */
/* using a parmlib_suffix ("Global Parmlib Suffix"). */
/* */
/* The typical user (probably) does not need to be */
/* concerned with the parmlib_dataset/parmlib_suffix */
/* options. */
/* Simply enter the SQL command and press enter. */
/* By default, the RSPINIT/RSPDEF clists will: */
/* a) determine the previously-used parmlib_dataset */
/* b) determine the default parmlib_suffix (ENVDEF) */
/* c) perform allocations and establish runtime */
/* environment */
/* ISQL will then be started, using settings from your */
/* previous session (including DB2 subsystem), which are */
/* stored in your Profile. */
/* */
/* In other words, the only pre-requisite to using this */
/* clist is that you must have entered the product and */
/* connected to a DB2 subsystem at least one time */
/* previously. By doing so, the parmlib_dataset name */
/* that you used would have been saved into your */
/* profile, making it available here. */
/* */
/* Installation : */
/* */
/* If you install this clist into another library, */
/* then you also must install the RSPDEF, RSPINIT, and */
/* RSPFREE clists into the same library. */
/* */
/* Limitations: */
/* */
/* Each time you enter the CA-DB2 Tools, your */
/* parmlib_dataset name is stored in your profile, */
/* making it available to subsequent sessions. */
/* This is good. */
/* */
/* However, the parmlib_suffix is NOT saved. */
/* */
/* Bottom line, the impact that this has on the usage of */
/* the SQL clist is this: */
/* => if your installation uses suffixes, and if you use */
/* any suffix other than the default suffix, then you */
/* need to specify the suffix each time you use the */
/* SQL clist... */
/* => Even if you use the SAME suffix every time, if it */
/* is not the default suffix, then you need to specify */
/* the suffix. */
/* => If you specify a parmlib_dataset name, then you */
/* should also specify a parmlib_suffix (unless you */
/* intend to use the default, in which case you */
/* should NOT specify the parmlib_suffix) */
/* => If you intend to use the default parmlib_suffix, */
/* whatever that happens to be for your shop, then */
/* DO NOT specify a parmlib_suffix on the clist... */
/* (this is the reason why we do not save and */
/* re-use the prior parmlib_suffix). */
/* */
/* */
/* Reference: Consult with your System Administrator to determine */
/* which parmlib & suffixes are valid at your */
/* installation. */
/* */
/* See the CA-DB2 Tools Installation Guide for a */
/* complete description of the Global Parmlib Suffix, */
/* and the Parmlib(DSNAME) member, for more information. */
/* */
/* */
/* Syntax : SQL subsystem parmlib_suffix parmlib_dsname */
/* . . parmlib_ddname */
/* DD:parmlib_ddname */
/* . */
/* */
/* Parameters : */
/* */
/* All arguments are optional. A period (.) may be */
/* used as a placeholder, to indicate a blank/default */
/* value. */
/* */
/* */
/* subsystem */
/* */
/* DB2 subsystem ID. */
/* */
/* If not specified, ISQL automatically connects */
/* to the DB2 subsystem ID used during the last */
/* CA DB2 Products session. */
/* */
/* parmlib_suffix */
/* */
/* "Global Parmlib Suffixes" allow you to have */
/* multiple versions of the same global parmlib */
/* member for different environments. */
/* */
/* See your System Administrator for information */
/* about SUFFIX parameters that are valid for */
/* your installation. */
/* */
/* parmlib_dsname */
/* parmlib_ddname */
/* DD:parmlib_ddname */
/* */
/* At the very minimum, a parmlib must be identified, */
/* in order to start the CA-DB2 Tools. */
/* */
/* This parameter provides the ability to */
/* specify the PARMLIB DATASET NAME (a single */
/* dataset), or the DDNAME of an existing parmlib */
/* allocation. */
/* */
/* If no parmlib is specified, then the CA-DB2 Tools */
/* will use the PARMLIB that was used the last time */
/* that you used the CA-DB2 Tools. */
/* */
/* There are 2 formats for the DDNAME specification. */
/* You may use the "DD:" prefix to indicate a ddname, */
/* or you can specify just the ddname by itself, */
/* without the "DD:" prefix. */
/* If the value does not have the "DD:" prefix, */
/* and is 8 characters or less, and contains */
/* no periods, then it is assumed to be a ddname. */
/* Otherwise it is assumed to be a dataset name. */
/* */
/* Specifying the dataset name: */
/* The dsname must be fully qualified... */
/* It does not matter if it is quoted or not... */
/* It is treated as if it were a fully qualified, */
/* quoted, dataset name in either case. */
/* */
/* Example1 : SQL */
/* */
/* Jump into ISQL, connecting to the DB2 subsystem */
/* that you used last time, using the same parmlib that */
/* you used last time, and the default suffix (blank). */
/* */
/* Example2 : SQL db2p */
/* */
/* Jump into ISQL, connecting to the DB2P subsystem, */
/* again using the same parmlib that you used last time, */
/* and the default suffix (blank). */
/* */
/* Example3 : SQL db2p 03 */
/* */
/* Jump into ISQL, connecting to the DB2P subsystem, */
/* again using the same parmlib that you used last time, */
/* but this time using the '03' suffix (which is */
/* defined by your site) and which establishes a */
/* particular set of parmlib/member options. */
/* */
/* Example4 : SQL db2p . company.parmlib.data.set.name */
/* */
/* Jump into ISQL, connecting to the DB2P subsystem, */
/* specifying a parmlib dataset name. The '.' in the */
/* 3rd argument is a placeholder, indicating the the 3rd */
/* argument (the suffix) is blank. */
/* */
/* Note: you may only specify a single dataset name. */
/* */
/* Example5 : SQL db2p . MYPARMDD */
/* or : SQL db2p . DD:MYPARMDD */
/* */
/* Same as example #4, but in this case you have already */
/* allocated the parmlib dataset(s) to the MYPARMDD */
/* ddname. */
/* */
/* Use a pre-allocated DDNAME if you need to */
/* concatenate multiple parmlib datasets. */
/* */
/* Error messages : */
/* */
/* This section provides a few hints & tips for */
/* determining the cause of some of the most common */
/* errors. This section is not exhaustive... */
/* */
/* */
/* Unable to start ISQL */
/* If the message text says */
/* "THE RSPDEF CLIST ENDED WITH A RC=12" */
/* then the most likely cause is that the */
/* RSPDEF, RSPINIT, RSPFREE clists were not installed */
/* along with this ISQL clist, or else the clist */
/* library is not allocated to SYSPROC. */
/* */
/*********************************************************************/
/* For the developer: */
/* */
/* ISQL and SQL clists are identical, except for the following: */
/* - ISQL is invoked as TSO command, SQL is an edit macro */
/* - ISQL uses keywords, SQL uses positional arguments and uses */
/* a period (.) as a placeholder */
/* - ISQL passes a 'comment' in lieu of a piece of sql text; */
/* SQL extracts a string of text from the member & passes it. */
/* */
/*********************************************************************/
/* Maintenance Log: */
/* */
/* DATE ISSUE# PROBLEM# PROGRAMMER TAPE */
/* -------- -------- -------- ---------- ------ */
/* 04/12/01 10646315 PDHULM P99F */
/* New. */
/* Total re-write. */
/* Removed all ALLOCs/LIBDEFs; replaced with */
/* calls to RSPDEF/RSPINIT/RSPFREE; added parmlib/suffix */
/* parameters, and everything else. */
/* */
/* 12/01/03 13104382-1 GEN 278 PDLIT @01 P01F */
/* */
/* Removed split screen limitation. This clist will now continue */
/* when a second instance of the CA-DB2 products is running. */
/* The split screen warning messages have also been */
/* removed since PTLDRIVM will display a split screen warning */
/* panel. */
/* */
/*********************************************************************/
IF &RECURS EQ NO THEN DO
ISREDIT MACRO (SSID,SUFFIX,PARMLIB) NOPROCESS
END
CONTROL NOFLUSH NOMSG NOPROMPT NOLIST
ISPEXEC CONTROL ERRORS RETURN
SET &NULL = &STR()
SET &RSPDEF_FATAL_ERROR = NO
/*********************************************************************/
/* Convert placeholders to blanks. */
/*********************************************************************/
IF &STR(&SSID) EQ &STR(.) THEN SET &SSID=&STR()
IF &STR(&SUFFIX) EQ &STR(.) THEN SET &SUFFIX=&STR()
IF &STR(&PARMLIB) EQ &STR(.) THEN SET &PARMLIB=&STR()
/*********************************************************************/
/* Check for rc application id. If we are currently */
/* under a different id recursively invoke ourselves. */
/*********************************************************************/
ISPEXEC VGET (ZAPPLID)
IF &ZAPPLID NE &STR(RC) THEN DO
IF &STR(&SSID) NE THEN SET &SSID=&STR(SSID(&SSID))
IF &STR(&SUFFIX) NE THEN SET &SUFFIX=&STR(SUFFIX(&SUFFIX))
IF &STR(&PARMLIB) NE THEN SET &PARMLIB=&STR(PARMLIB(&PARMLIB))
ISPEXEC SELECT -
CMD(%&SYSICMD -
&SSID &SUFFIX &PARMLIB RECURS(YES)) -
NEWAPPL(RC) -
PASSLIB
SET &SQLCC = &LASTCC
EXIT CODE(&SQLCC)
END
/*********************************************************************/
/* If PARMLIB was not passed as an argument, then we will use */
/* the PARMLIB that was established the last time they used the */
/* CA-DB2 Tools. This means that the CA-DB2 Tools must have been */
/* entered at least 1 time previously. */
/*********************************************************************/
IF &STR(&PARMLIB) EQ THEN DO
ISPEXEC VGET (PTIPARM)
IF &STR(&PTIPARM) EQ THEN DO
SET &ZEDSMSG = &STR(PARMLIB NOT SET)
SET &ZEDLMSG = &STR(You did not specify a PARMLIB,)
SET &ZEDLMSG = &STR(&ZEDLMSG and a default PARMLIB has not)
SET &ZEDLMSG = &STR(&ZEDLMSG been set.)
SET &ZEDLMSG = &STR(&ZEDLMSG You must specify a PARMLIB,)
SET &ZEDLMSG = &STR(&ZEDLMSG or, you must have entered)
SET &ZEDLMSG = &STR(&ZEDLMSG the CA Products for DB2)
SET &ZEDLMSG = &STR(&ZEDLMSG at least 1 time previously,)
SET &ZEDLMSG = &STR(&ZEDLMSG in order for this clist to work)
ISPEXEC SETMSG MSG(ISRZ001)
EXIT CODE(12)
END
END
/*********************************************************************/
/* If SSID was not passed as an argument, then we will use */
/* the SSID that was established the last time they used the */
/* CA-DB2 Tools. This means that the CA-DB2 Tools must have been */
/* entered at least 1 time previously. */
/*********************************************************************/
IF &STR(&SSID) EQ THEN DO
ISPEXEC VGET (SYS)
IF &STR(&SYS) EQ OR &STR(&SYS) EQ &STR(SSID) THEN DO
SET &ZEDSMSG = &STR(DB2 SUBSYSTEM NOT SET)
SET &ZEDLMSG = &STR(You did not specify a DB2 SSID,)
SET &ZEDLMSG = &STR(&ZEDLMSG and a default SSID has not)
SET &ZEDLMSG = &STR(&ZEDLMSG been set.)
SET &ZEDLMSG = &STR(&ZEDLMSG You must specify a DB2 SSID,)
SET &ZEDLMSG = &STR(&ZEDLMSG or, you must have entered)
SET &ZEDLMSG = &STR(&ZEDLMSG the CA Products for DB2)
SET &ZEDLMSG = &STR(&ZEDLMSG at least 1 time previously and)
SET &ZEDLMSG = &STR(&ZEDLMSG connected to a DB2 subsystem,)
SET &ZEDLMSG = &STR(&ZEDLMSG in order for this clist to work)
ISPEXEC SETMSG MSG(ISRZ001)
EXIT CODE(12)
END
END
/*********************************************************************/
/* Identify line commands to be used by this system. */
/* If they did not enter E or EE/EE, exit with msg. */
/*********************************************************************/
ISREDIT PROCESS RANGE E
IF &LASTCC ^= 0 THEN DO
SET &ZEDSMSG = &STR(BLOCK COMMAND INCOMPLETE)
SET &ZEDLMSG = &STR(SQL QUERY MUST BE MARKED WITHIN)
SET &ZEDLMSG = &STR(&ZEDLMSG PROGRAM BY EE/EE LINE COMMANDS)
ISPEXEC SETMSG MSG(ISRZ001)
EXIT CODE(12)
END
/*********************************************************************/
/* Obtain the logical data width, */
/* and substring DLEN to 3 chars. */
/*********************************************************************/
ISREDIT (DLEN) = DATA_WIDTH
SET &VLEN = &LENGTH(&STR(&DLEN))
IF &VLEN > 3 THEN -
SET &DLEN = &SUBSTR(&VLEN-2:&VLEN,&DLEN)
/*********************************************************************/
/* Isolate the desired lines of sql. */
/*********************************************************************/
ISREDIT (FLINE) = LINENUM .ZFRANGE
ISREDIT (LLINE) = LINENUM .ZLRANGE
/*********************************************************************/
/* Create 1 variable with all of the sql in it, */
/* using at most 72 bytes of data. */
/* If cobol, then use only 66 bytes of data. */
/*********************************************************************/
SET COUNT = &FLINE
SET SQLTEXT = &STR()
DO WHILE (&COUNT ^> &LLINE)
ISREDIT (SQ) = LINE &COUNT
IF &DLEN > &STR(072) THEN -
IF &DLEN = &STR(074) THEN -
SET SQLTEXT = &STR(&NRSTR(&SQLTEXT)&SUBSTR(1:66,&NRSTR(&SQ)))
ELSE -
SET SQLTEXT = &STR(&NRSTR(&SQLTEXT)&SUBSTR(1:72,&NRSTR(&SQ)))
ELSE -
SET SQLTEXT = &STR(&NRSTR(&SQLTEXT)&NRSTR(&SQ))
SET COUNT = &COUNT+1
END
/*********************************************************************/
/* If actual data width is greater than 72 use 72, */
/* except if the length is 74 in which case the edit */
/* profile is number on cobol and data width is 66. */
/*********************************************************************/
IF &DLEN > &STR(072) THEN -
IF &DLEN = &STR(074) THEN -
SET &DLEN = &STR(066)
ELSE -
SET &DLEN = &STR(072)
/********************************************************************/
/* Parse dsname/ddname argument */
/********************************************************************/
SET &PARM = &STR()
SET &CHECK_DATASET_NAME = NO
IF &STR(&PARMLIB) NE THEN DO
IF &SUBSTR(1:1,&STR(&PARMLIB)) EQ &STR(') OR +
&SUBSTR(1:1,&STR(&PARMLIB)) EQ &STR(") THEN DO
/* strip quotes */
SET &PARMLIB = &SUBSTR(2:&LENGTH(&PARMLIB)-1,&STR(&PARMLIB))
END
IF &LENGTH(&STR(&PARMLIB)) GT 3 THEN DO
/* DD:ddname ?
SET &PREFIX = &SUBSTR(1:3,&STR(&PARMLIB))
IF &STR(&PREFIX) = &STR(DD:) THEN +
SET &PARM = &STR(PARMLIB(&PARMLIB))
END
IF &STR(&PARM) EQ THEN DO
/* if the length of PARMLIB is <= 8
/* and contains no period,
/* then it is a DDNAME.
/* otherwise it is a DSNAME
SET &LEN = &LENGTH(&STR(&PARMLIB))
SET &DOT = &SYSINDEX(&STR(.),&STR(&PARMLIB))
IF &LEN LE 8 AND &DOT EQ 0 THEN DO
SET &PARM = &STR(PARMLIB(DD:&PARMLIB))
END
ELSE DO
SET &PARM = &STR(PARMLIB(&PARMLIB))
SET &CHECK_DATASET_NAME = YES
END
END
/* if dataset name given, then verify it...
/* the RSPDEF clist always treats the dataset name as
/* fully qualified, regardless whether it is quoted or not...
/* so, we'll do the same here...
IF &CHECK_DATASET_NAME = YES THEN DO
SET &SYSDSN_RESULT = &SYSDSN('&PARMLIB')
IF &STR(&SYSDSN_RESULT) NE OK THEN DO
SET &ZEDSMSG = &STR(PARMLIB DATASET ERROR)
SET &ZEDLMSG = &STR('&PARMLIB' &SYSDSN_RESULT)
ISPEXEC SETMSG MSG(ISRZ001)
EXIT CODE(12)
END
END
END
/********************************************************************/
/* Call RSPDEF to drive online allocations. */
/********************************************************************/
/* RSPDEF will end with RC=4 if split screen detected... */
/********************************************************************/
%RSPDEF 'SUFFIX(&SUFFIX) &PARM'
SET &RC = &LASTCC
IF &RC GT 4 THEN DO
SET &RSPDEF_FATAL_ERROR = YES
GOTO DONE
END
%RSPINIT
/*********************************************************************/
/* Call ISQL, let it grab the sql from clist var */
/*********************************************************************/
/* Important note: */
/* */
/* If PTLDRIVM encounters an error and does a setmsg, it will exit */
/* and the message will be displayed in the current edit window... */
/* */
/* This is good, except that there may be a .HELP panel associated */
/* with the error, and if the user hits PF1 they will get an ISPF */
/* Dialog Error "panel not found" and they will be kicked out of the */
/* edit session -- because the HELP panel library is not allocated. */
/* */
/* Unfortunately, from a programming point-of-view, there is */
/* nothing at all that we can do about this. The only work-around */
/* is for the user to permanently allocate the HELP panels in the */
/* TSO logon proc... */
/* Which is actually not a bad thing to do (hint, hint). */
/*********************************************************************/
IF &STR(&SUFFIX) EQ THEN +
DO
ISPEXEC SELECT -
PGM(PTLDRIVM) -
PARM(CI=IQLSQL/&DLEN&SSID) -
NEWAPPL(RC) -
PASSLIB
END
ELSE +
DO
ISPEXEC SELECT -
PGM(PTLDRIVM) -
PARM(CI=IQLSQL,SUFFIX=&SUFFIX/&DLEN&SSID) -
NEWAPPL(RC) -
PASSLIB
END
/*********************************************************************/
/* Cleanup: */
/* Call RSPFREE to release our allocations. */
/*********************************************************************/
DONE: &NULL
%RSPFREE
IF &RSPDEF_FATAL_ERROR = YES THEN DO
SET &ZEDSMSG = &STR(Unable to start ISQL)
SET &ZEDLMSG = &STR(The RSPDEF clist ended with a RC=&RC..)
SET &ZEDLMSG = &STR(&ZEDLMSG RSPDEF is responsible)
SET &ZEDLMSG = &STR(&ZEDLMSG for processing the parmlib/suffix,)
SET &ZEDLMSG = &STR(&ZEDLMSG and allocating runtime libraries.)
SET &ZEDLMSG = &STR(&ZEDLMSG The clist encountered an error, and)
SET &ZEDLMSG = &STR(&ZEDLMSG processing terminated.)
SET &ZEDLMSG = &STR(&ZEDLMSG Correct your parmlib/suffix)
SET &ZEDLMSG = &STR(&ZEDLMSG specification, and try again.)
ISPEXEC SETMSG MSG(ISRZ001)
END
EXIT CODE(0)
}¢--- A540769.WK.REXX(CAT) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ------
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
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.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
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
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
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.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
if oKindOfString(m) then
return oNew('FileList', dsn2Jcl(oAsString(m)), opt)
else
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
}¢--- A540769.WK.REXX(CATCOPRE) cre=2012-09-26 mod=2012-09-26-11.13.47 A540769 ---
call sqlConnect dbof
say time() 'start'
$;
$>DSN.CATCOPRE.OUT ::v
$<=¢
with p as
(
select dbName db, tsName ts, partition part,
( select max(f.timestamp) from sysibm.sysCopy f
where p.dbName = f.dbName and p.tsName = f.tsName
and f.dsNum in (p.partition, 0)
and f.icType in ('F', 'R','X')
) laFu
from sysibm.sysTablePart p
where dbName like '%'
)
select db, ts, part, laFu,
c.icType, c.dsNum, c.Timestamp, c.dsName
from p left join sysibm.sysCopy c
on p.db = c.dbName and p.ts = c.tsName
and c.dsNum in (p.part, 0)
and c.icType in ('F', 'I', 'R','X')
and c.timestamp >= laFu
order by p.db, p.ts, p.part, c.timestamp desc
$!
call sqlSel
cFet = 0
cInc = 0
cFul = 0
cOk = 0
cArc = 0
cErr = 0
lEla = 0
$|
say time() 'first'
$@forWith cc $@¢
cFet = cFet + 1
if $ICTYPE = 'F' then
cFul = cFul + 1
else if $ICTYPE = 'I' then
cInc = cInc + 1
else
iterate
arc = dsnArc($DSNAME)
if arc = 'ok' then do
cOk = cOk + 1
end
else do
if arc = 'arc' then
cArc = cArc + 1
else
cErr = cErr + 1
$$- left($DB, 8) left($TS,8) right($PART, 4) $*+
$LAFU $ICTYPE right($DSNUM, 4) left($DSNAME,46) arc
end
if time('e') > lEla then do
say time() cFet 'fet,' cInc 'inc,' cFul 'ful,' ,
cOk 'dsnOK,' cArc 'arc,' cErr 'err,' $DB $TS
lEla = time('e') + 10
end
$!
say time() cFet 'fetch,' cInc 'incremental,' cFul 'full,' ,
cOk 'dsn ok,' cArc 'archived,' cErr 'errors'
call sqlDisconnect
$#out 20130101 10:50:54
$#out 20130101 10:50:21
$#out 20130101 10:45:54
$#out 20130101 10:43:27
*** run error ***
tsoAlloc rc 12 for alloc dd() DSN('DSN.CATOPTRE.OUT')
$#out 20130101 10:33:10
$#out 20130101 10:32:02
$#out 20130101 10:28:01
}¢--- A540769.WK.REXX(CAX) cre=2012-11-14 mod=2016-08-30-11.20.42 A540769 ------
/* rexx ----------------------------------------------------------------
Credit Suisse line commands in RCQ walter 15. 7.16
c1 : db2 catalog rows for this line
cx : db2 catalog rows for all lines of currently displayed list
rts or r1: realTimeStats rows for this line
rx : realTimeStats rows for all lines of currently displayed list
The above commands show their result in an editSession
you find the selection path and sql at the bottom
within this editSession the same commands act as editMacros
$br or $ed: browse or edit table on this line with fileAid
editMacros
cx in command line: show data as table (one row a line)
c1 in command line and cursor on target line:
show data for selected line, one column a line
rx in command line: show related realTimeStats as table
rts or r1 in command line and cursor on target line:
show realTimeStats related to selected line, one column a line
the above editMacros allow arguments to select related db2 objects
e.g. cx pk: related packages, cx ik: related index keys
the syntax for the argumnts is richer: ct* (':' ct)?
ct: abbreviations for db2 catalog tables (lowercase|)
c co=syscopy db i ik=indexKey ip pk pkd ri rt t tg tp ts v vd
ct before the colon
first: target catalog table
following: intermediates on the new selection path
ct after the colon: starting point in the old selection path
$br or $ed: browse or edit table on cursor line with fileAid
{u
ux: erstellt utilities/rebinds fuer angezeigte Objekte
macro arguments: Liste von Utilities, abkuerzung erlaubt:
copy cd=checkData ce=checkDataExceptionTables ci=checkIndex
loaddummy=dummy reorg runstats
rebind=rbind rebuild=build recover=rcover unload
help: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.CaCatCx {
history
toDo: mit neuem F module alle RBAs auf timestamp uebersetzen
15. 7.16 walter : mit caxIdKeys. neuen copies etc.
------------------------------*/ /*--- end of help ---------------------
18. 4.16 walter : mit runstats profile fuer umgestellte RZ, unload
12. 4.16 walter : neue recover views
22.12.15 stephan: class=m1, reorg mit auto mappingtable
1.10.15 walter: recover (cx rc und ux rc) auch fuer xDocs eingebaut
cx co verschoenert
21.12.15 walter: fadCall statt rCallFAD
18.02.15 walter: rba for v11 and allow wildcard=*
28.11.13 walter: exceptionTB mit including identity
20.11.13 walter: exceptionTB inherits BP, added missing end in anaList
13.11.13 walter: variable length keys empty or with . (pk|)
4.11.13 walter: pit_rba in recovery und scroll left
20. 8.13 walter: variable length keys in ganzer Laenge am Schluss
19. 8.13 walter: cd, ce, ci checkData/Exceptions, checkIndex
13. 6.13 walter: neuer server name
19. 4.13 walter: $ed,$br,rts=r1 +rx, help fuer cx etc. ohne ux, errors
17. 4.13 walter: fix relation c <-> t v
4. 4.13 walter: fix copy parallel
3. 4.13 walter: fix c1/r1 auf ts, relationship tg -> t v
?. 3.13 walter: neu geschrieben
----------------------------------------------------------------------*/
parse arg who, a1
m.debug = 0
if who == '' then
return tstTkrPath()
m.cmd = who
call errReset 'hi'
m.err_helpOpt = if(translate(left(who, 1)) = 'U', 'u', 'e')
say 'exectst(cax) 11.7.16' who '('a1')'
isEdit = 0
if a1 == '' then /* check if editMacro */
if m.err_ispf then
isEdit = adrEdit('macro (a1) PROCESS', '*') == 0
if pos('?', who a1 ) > 0 then
exit help()
call pipeIni
call scanReadIni
call sqlOIni
call tkrIniDb2Cat
/* do the requested work */
if who == 'CX'| who == 'C1' then do
if isEdit then
return catEditMacro('=', who == 'CX', a1)
else
return catRCQueryCmd('=', who == 'CX')
end
else if who = 'RX' | who == 'R1' | who == 'RTS' then do
if isEdit then
return catEditMacro('r', who == 'RX', a1)
else
return catRCQueryCmd('r', who == 'RX')
end
else if who == 'UX' | who == 'U1' then do
if isEdit then
return uxEditMacro('ux', a1, who == 'UX')
else if a1 == '' then
return uxRCQueryCmd()
end
else if who == '$ED' then
return fileAid(isEdit, 'edit')
else if who == '$BR' then
return fileAid(isEdit, 'browse')
exit errHelp('command='who 'args='a1', edit='isEdit 'not implemented')
/*--- called by a rcQuery USALINE Command ---------------------------*/
catRCQueryCmd: procedure expose m.
parse arg ty, all
m='cat'
if all then
sq = anaRCQAll(m)
else
sq = anaRCQOne(m)
if ty == 'r' then do
parse var sq sTys ':'
sTy = word(sTys, 1)
sq = if(pos('i', sTy) > 0, 'ri', 'rt') sq
end
else if ty \== '=' then
call err 'bad ty' ty 'in catRCQueryCmd'
parse var sq sTys ':' wh
sTy = word(sTys, 1)
call sqlConnect m.m.dbSy
call pipe '+F', fEdit('::v', 0)
call out ' *' m.m.func '? = help, PF3 = zurück zu' ,
'rcQuery' m.m.hTb m.m.hOp
call sqlCatTb sTy, tkrWhere(,sq), tkrTable(, sTy, 'o'), all
call pipe '-'
call sqlDisconnect
return 0
endProcedure catRCQueryCmd
/*--- called by editmacro: analyze edit data -------------------------
and finally create and show output ------------------------*/
catEditMacro: procedure expose m.
parse arg ty, all, pPa ':' sPa
m='cat'
call anaEditSql m
nPa = ''
do px=1 to words(pPa)
nd = word(pPa, px)
if abbrev(nd, '-') then
call handleOpt nd
else if tkrTable(tkr, nd, , '') \== '' then
nPa = nPa nd
else
call err 'i}'nd 'not a table in path' arg(3)
end
if nPa = '' then
nPa = word(m.m.path, 1)
if sPa = '' then
sPa = word(m.m.path, 1)
else if \ all then
call err 'i}startPath :'sPa 'not allowed for' m.m.func
px = wordPos(sPa, m.m.path)
if px < 1 then
call err 'i}start' sPa 'not in path' m.m.path 'args:' nPa':'sPa
if ty == 'r' then
nPa = if(pos('i', word(nPa, 1)) > 0, 'ri', 'rt') nPa
else if ty \== '=' then
call err 'bad ty' ty
if all then do
sx = m.m.sql.0 + 1 - px
sq = m.m.sql.sx
parse var sq sFr sTb sAl . 'where' wh
if sAl \== sPa then
call err 'i}start' sPa '<> al' sAl 'in' sq
sTb = tkrTable(tkr, sPa, , '')
if '' == sTb then
call err 'i}start' sPa 'not a table'
wh = strip(wh)
if abbrev(wh, m.sTb.cond) then
wh = strip(substr(wh, length(m.sTb.cond)+1))
else
call err sPa 'cond' m.sTb.cond 'does not start where:' wh
/* if sx > 1 then do
pPa = word(m.m.path, px+1)
if m.tkr.sPa.pPa == 'relation' then
ky = tkr'.'sPa'.'pPa'.LEF'
else if m.tkr.pPa.sPa == 'relation' then
ky = tkr'.'pPa'.'sPa'.RIG'
else
call err 'relation' sPa'.'pPa 'not declared'
if abbrev(wh, m.ky.cond) then
wh = strip(substr(wh, length(m.ky.cond)+1))
else if m.ky.cond <> '' then
call err sPa 'cond' m.ky.cond 'does not start where:' wh
end ?????? falsche Richtung? */
if px > 1 then do
pPa = word(m.m.path, px-1)
if symbol('m.tkr.t2t.sPa.pPa') == 'VAR' then
ky = m.tkr.t2t.sPa.pPa'.LEF'
else if symbol('m.tkr.t2t.pPa.sPa') == 'VAR' then
ky = m.tkr.t2t.pPa.sPa'.RIG'
else
call err 'relationShip' sPa'.'pPa 'not declared'
ky = tkrKey(ky)
if abbrev(wh, m.ky.cond) then
wh = strip(substr(wh, length(m.ky.cond)+1))
else
call err sPa 'cond' m.ky.cond 'does not start where:' wh
end
do lx = sx-1 by -1 to 1
wh = wh m.m.sql.lx
end
bc = m.m.sql.0 - 1
do bx = length(wh) by -1 to 1 while bc > sx - 1
b1 = substr(wh, bx, 1)
if b1 = ')' then
bc = bc - 1
else if b1 \== ' ' then
leave
end
wh = strip(left(wh, bx))
end
else do
px = 1
call anaEditList m, 0
sKy = mGet(tkrTable(, sPa)'.PKEY')
wh = list2where(m'.LST', sKy)
end
nTy = word(nPa, 1)
call sqlConnect m.m.dbSy
b = jBuf()
call pipe '+F', b
call out m.m.help
call sqlCatTb nTy, tkrWhere(, nPa sPa':' wh),
, , all,
, if(all, subWord(m.m.path, px+1))
call pipe '-'
call adrEdit 'delete .zf .zl'
call adrEdit 'reset'
do bx=1 to m.b.buf.0
li = m.b.buf.bx
call adrEdit 'line_after .zl = (li)'
end
call sqlDisconnect
call adrEdit 'locate .zf'
call adrEdit 'left max'
return 1
endProcedure catEditMacro
/*--- called by editmacro: analyze edit data -------------------------
and finally create job with utilities ---------------------*/
uxEditMacro: procedure expose m.
parse arg m, parms, all
call anaEditSql m
l = m'.LST'
m.l.0 = 0
call anaEditList m, all
b = jBuf()
call pipe '+F', b
call genJob m, l, t1, parms
call pipe '-'
call adrEdit 'delete .zf .zl'
call adrEdit 'reset'
do bx=1 to m.b.buf.0
li = m.b.buf.bx
call adrEdit 'line_after .zl = (li)'
end
hh = m.m.help
call adrEdit 'line_before .zf = infoLine (hh)'
call adrEdit 'locate 1'
call adrEdit 'left max'
/*call adrEdit 'up max' */
return 1
endProcedure uxEditMacro
/*--- command to reload tecSv unload tables -------------------------*/
handleOpt: procedure expose m.
parse upper arg opt
m = 'cat'
if opt == '-RU' then
call adrTso "ex 'dsn.db2.exec(tecSvUnl)' '"m.m.dbSy"'", '*'
else
call err "i}option '"opt"' not supported"
return
endProcedure handleOpt
/*--- call fileAid for $ed and $br commands -------------------------*/
fileAid: procedure expose m.
parse arg isEdit, faFun
m='cat'
if isEdit then do
call anaEditSql m
l = m'.LST'
m.l.0 = 0
call anaEditList m, 0
if m.l.0 = 1 & m.l.alias = 't' then
return callFA(faFun, m.m.dbSy, m.l.1.2, m.l.1.1)
call err 'i}not a single table but' m.l.0 m.l.alias
end
else do
sq = anaRCQOne(m)
if m.m.lTb == 't' then
return callFA(faFun, m.m.dbSy, m.m.lNm, m.m.lQu)
call err 'i}not a single table but' m.m.lTb
end
endProcedure fileAid
callFA: procedure expose m.
parse arg faFun, dbSy, tb, cr
call adrTso "exec 'dsn.db2.exec(fadCall)' '"faFun dbSy tb cr"'"
return 0
endProcedure callFAD
/*--- does not work, never called -----------------------------------*/
uxRCQueryCmd: procedure expose m.
m='ux'
call anaRCQ m
call sqlConnect m.m.dbSy
fe = jOpen(fEdit(), '>')
call jWrite fe, 'who' sysvar(sysnode) m.m.dbSy userid() m.m.screen
call jWrite fe, 'sel' cTy m.m.hCr'.'m.m.hNm
call sql2St 'select creator cr, name tb, dbName db, tsName ts',
genSql(m, 't'), sq
if m.sq.0 <> m.m.lines then
say 'warning: select' m.sq.0 'rows <->' m.m.lines 'on screen',
'this might be a program ERROR|'
do sx=1 to m.sq.0
call jWrite fe, ' ts' left(m.sq.sx.db'.'m.sq.sx.ts,18) ,
't' m.sq.sx.cr'.'m.sq.sx.tb
end
call sqlDisconnect
call jCLose(fe)
return 0
endProcedure uxRCQueryCmd
/*--- ana RCQ Screen for ALL of selection ---------------------------
using contents of selection entered ---------------*/
anaRCQAll: procedure expose m.
parse arg m
call anaRCQInfo m
m.m.predFlds = '? ? HNM HCR HQU HPKVERS HROVERS'
return anaRCQ(m, m.m.hTb, m.m.hOp)
endProcedure anaRCQAll
/*--- ana RCQ Screen for One (the cursor) line ----------------------*/
anaRCQOne: procedure expose m.
parse arg m
call anaRCQInfo m
m.m.predFlds = '? ? LNM LQU PART LPANM COLLECTION CONTOKEN VERSION'
ty = m.m.lTb
if ty == 'c' & m.m.hTb == 'i' then
return anaPred(m, 'ik', 'ikk.colName', 'creator', , 'name')
else if ty == 'c' & wordPos(m.m.hTb, 't v') > 0 then
return anaPred(m, 'c', 'name', 'tbCreator', , 'tbName')
else if ty == 'ip' then
return anaPred(m, 'ip', 'ixname', 'ixCreator', 'partition')
else if ty == 'pk' then
return anaPred(m, 'pk', 'name', 'owner',,, 'collid',
, 'conToken', 'version')
else if ty == 'tg' & m.m.hTb == 't' then
return anaPred(m, 'tg', 'name', 'tbOwner', , 'tbName')
else if ty == 'ts' then
return anaPred(m, 'ts', 'name', 'dbName')
else if ty == 'tp' then
return anaPred(m, 'tp', 'tsname', 'dbName', 'partition')
else /* other cases work with anaRCQ */
return anaRCQ(m, ty, 'd')
endProcedure anaRCQOne
/*--- analyze rcq infos: which catalog table, wich operation
which sql to retrieve rows
return op sql ---------------------------------------------*/
anaRCQ: procedure expose m.
parse arg m, ty, op
tyOp = ty':'op
if ty == 'c' then
sq = anapred(m, 'c', 'name', 'tbCreator')
else if tyOp == 'db:i' then
sq = anapred(m, 'i', 'dbName')
else if tyOp == 'db:t' | tyOp = 'db:v' then
sq = anapred(m, 't', 'dbName')
else if tyOp == 'db:ts' then
sq = anapred(m, 'ts', 'dbName')
else if ty = 'db' then
sq = anapred(m, 'db', 'name')
else if tyOp == 'i:c' then
sq = anaPred(m, 'ik', 'name', 'creator')
else if tyOp == 'i:pl' then
sq = anaPred(m, 'ip', 'ixName', 'ixCreator')
else if ty == 'i' then
sq = anaPred(m, 'i', 'name', 'creator')
else if ty == 'pk' then
sq = anaPred(m, 'pk', 'name', 'owner', 'collid', 'version')
else if tyOp == 't:i' then
sq = anaPred(m, 'i', 'tbName', 'tbCreator')
else if tyOp == 't:tg' then
sq = anaPred(m, 'tg', 'tbName', 'tbOwner')
else if ty == 't' then
sq = anaPred(m, 't', 'name', 'creator')
else if ty == 'tg' then
sq = anaPred(m, 'tg', 'name', 'tbOwner')
else if tyOp == 'ts:pl' then
sq = anaPred(m, 'tp', 'tsName', , 'dbName')
else if ty == 'ts' then
sq = anaPred(m, 'ts', 'name', 'creator', 'dbName')
else if ty == 'v' then
sq = anaPred(m, 'v', 'name', 'creator')
else
call err 'type:opt' tyOp 'not implemented yet'
if tyOp == 'i:d' then
return 'ip' sq
else if tyOp == 'ts:d' then
return 'tp' sq
if op == 'l' | op == 'd' | op == 'pl' | tyOp = 'i:c' then
return sq
else
return op sq
endProcedure anaRCQ
/*--- build sql predicate -------------------------------------------*/
anaPred: procedure expose m.
parse arg m, ty
sq = ''
do ax=3 to arg()
f1 = word(m.m.predFlds, ax)
if f1 \== '' then
sq = strip(sq tkrPred( , ty, arg(ax), m.m.f1))
end
return ty':' substr(sq, 5)
endProcedure anaPred
/*--- get info from RCQ Screen --------------------------------------*/
anaRCQInfo: procedure expose m.
parse arg m
if 0 then do /* debug variable in pool ???? */
ll = 'rcqMCase subSys funcName' ,
'hTable relation hEntity hUser entQual user2 entVers' ,
'objType objName qual'
do lx=1 to words(ll)
vv = word(ll, lx)
x = value(vv, 'valueBefore')
call adrIsp 'vget ('vv') asis', '*'
say '?? vget rc='rc',' vv'='value(vv)
end
end
call adrIsp 'vget (subsys rcqmcase funcName' ,
' htable relation hEntity' ,
'hUser entQual user2 entVers entVers2' ,
'objtype qual objname) shared'
m.m.dbSy = subsys
m.m.qmCase = rcQmCase
m.m.func = funcName
m.m.hTb = hTable
m.m.hOp = relation
m.m.hNm = hEntity
m.m.hCr = hUser
m.m.hQu = entQual
m.m.hGr = user2
m.m.hPkVers = entVers
m.m.hRoVers = entVers2
m.m.lTb = objType
m.m.lqu = qual
m.m.lNm = objName
call anaRCQScreen m /* additional info only in screen text| */
m.m.hTb = ut2lc(m.m.hTb)
m.m.hOp = ut2lc(m.m.hOp)
m.m.lTb = ut2lc(m.m.lTb)
if 0 then do
ww = screen curPos curLine curWord lineF lines ,
dbSy lTb lQu lNm func hTb hOp wh hNm hCr hQu hGr
do wx=1 to words(ww)
w1 = word(ww, wx)
if wx <= 11 then
say left(w1, 10) m.m.w1'.'
else
say left(w1, 10) m.m.w1.lb'='m.m.w1'.'
end
end
return
endProcedure anaRCQInfo
/*--- get info from RCQ Screen that are not in variables ------------*/
anaRCQScreen: procedure expose m.
parse arg m
call adrIsp 'VGET (' zScreen zScreenW zScreenC zScreenI ')'
zScreenW = 80 /* breite Screens sind doch nicht so breit????*/
m.m.screen = zScreen
lx = zScreenC - ((zScreenC)//zScreenW) + 1
m.m.curPos = zScreenC || 'L' || ((zScreenC)%zScreenW+1) ,
|| 'C' || ((zScreenC)//zScreenW+1)
m.m.curLine = substr(zScreenI, lx, zScreenW)
sep = ' '
do wx=zScreenC+1 to lx+zScreenW-2 ,
while pos(substr(zScreenI, wx, 1), sep) > 0
end
do wx=wx by -1 to lx+1 ,
while pos(substr(zScreenI, wx-1, 1), sep) = 0
end
do wy=wx to lx+zScreenW-2 ,
while pos(substr(zScreenI, wy, 1), sep) = 0
end
m.m.curWord = substr(zScreenI, wx, wy-wx)
call anaHLine m, substr(zScreenI, 1+3*zScreenW, zScreenW),
, hTb, hOp, wh
call anaHLine m, substr(zScreenI, 1+4*zScreenW, zScreenW), hNm, hCr
call anaHLine m, substr(zScreenI, 1+5*zScreenW, zScreenW), hQu, hGr
l = substr(zScreenI, 6*zScreenW+1, zScreenW)
scx = 6
if word(l, 1) == 'Version' then
l = substr(zScreenI, ass('scx', 7)*zScreenW+1, zScreenW)
lx = lastPos('LINE', l)
isFrame = lx < 1
if isFrame then
lx = lastPos('FRAME', l)
if lx < 1 then
call err 'bad line of clause:' l
l = substr(l, lx, zScreenW-lx-1)
if word(l, 3) \== 'OF' then
call err 'bad line of clause:' l
m.m.lineF = word(l, 2)
m.m.lines = word(l, 4)
scx = scx + 1
tbOp = ut2lc(m.m.hTb':'m.m.hOp)
if tbOp = 't:c' | tbOp = 't:tg' | tbOp = 'v:c' then do
m.m.lPaNm = m.m.hNm
return
end
else if tbOp = 'i:c' then do
m.m.lPaNm = m.m.hNm
m.m.lQu = m.m.hCr
return
end
else if tbOp = 'ts:pl' then
jj = 'tp PART'
else if tbOp = 'ts:d' then
jj = 'tp PART'
else if tbOp = 'i:pl' then
jj = 'ip PART'
else if tbOp = 'i:d' then
jj = 'ip PART'
else if translate(m.m.lTb) == 'PK' then
jj = 'pk COLLECTION CONTOKEN'
else
return
m.m.lTb = word(jj, 1)
if \ isFrame then do
tiLi = translate(substr(zScreenI, 1+scX*zScreenW, zScreenW),
, ' ', '00'x)
if word(tiLi, 1) <> 'CMD' then
call err 'CMD not found on line' scx':'tiLi
do sx = 1+(scX+1) * zScreenW by zScreenW to length(zScreenI)
if substr(zScreenI, sx, 8) \= '' then
leave
end
cuLi = translate(substr(zScreenI, sx, zScreenW), ' ', '00'x)
cmd = translate(strip(substr(cuLi, 2, 8)))
if cmd \= m.m.func then
call err 'fun' m.m.func '<> cmd' cmd (sx%zScreenW)':' cuLi
if m.m.lTb = 'pk' then do
m.m.collection = lineFldOA('COLLEC', tiLi, cuLi)
m.m.contoken = lineFldOA('CONTOK', tiLi, cuLi)
m.m.version = lineFldOA('VERSI', tiLi, cuLi)
if length(m.m.version) > 18 then
m.m.version = m.m.version'%'
end
else do
do jx = 2 to words(jj)
f1 = word(jj, jx)
m.m.f1 = lineFld(f1, tiLi, cuLi)
end
end
end
else do
do sx = 1+(scX) * zScreenW by zScreenW to length(zScreenI)
if substr(zScreenI, sx, 6) == ' CMD: ' then
leave
end
cuLi = translate(substr(zScreenI, sx, zScreenW), ' ', '00'x)
if word(cuLi, 1) \== 'CMD:' then
call err ' CMD: not found'
cmd = translate(word(cuLi, 2))
if cmd \= m.m.func then
call err 'fun' m.m.func '<> cmd' cmd (sx%zScreenW)':' cuLi
needed = left(' 23456789ABCDEFG', words(jj), 'x')
do sx = sx + zScreenW by zScreenW to length(zScreenI) ,
while needed <> ''
do jx = 2 to words(jj)
f1 = word(jj, jx)
if abbrev(strip(substr(zScreenI, sx+1, 12)), f1) then do
cuLi = substr(zScreenI, sx, zScreenW)
cx = pos(':', cuLi)
if cx < 10 then
call err 'no or bad : in' cuLi
if substr(needed, jx, 1) == ' ' then
call err 'duplicate' f1
else
needed = overlay(' ', needed, jx)
m.m.f1 = word(substr(cuLi, cx+1, zScreenW), 1)
end
end
end
if needed <> '' then
call err 'still fields needed' needed 'jj:' jj
end
return
endProcedure anaRCQScreen
lineFld: procedure expose m.
parse arg f1, tiLi, cuLi
wx = wordPos(f1, tiLi)
if wx < 1 then
call err f1 'not in title' tiLi
bx = wordIndex(tiLi, wx)
ex = wordIndex(tiLi, wx+1)
if ex < 1 then
return strip(substr(cuLi, bx))
else
return strip(substr(cuLi, bx, ex-bx))
endProcedure lineFld
lineFldOA: procedure expose m.
parse arg abb, tiLi, cuLi
cx = pos(' 'abb, tiLi)
if cx < 1 then
return '*'
return lineFld(word(substr(tiLi, cx+1), 1), tiLi, cuLi)
endProcedure lineFldOA
/*--- analyze a RCQ header line -------------------------------------*/
anaHLine: procedure expose m.
parse arg m, li, f1, f2, f3
if substr(li, 14, 4) \== '===>' then
call err 'bad headerline1' li
m.m.f1.lb = strip(substr(li, 2, 12))
if m.m.f1 <> strip(substr(li, 19, 20)) then
call err f1 m.m.f1.lb':' m.m.f1 '<>' strip(substr(li, 19, 20))
if substr(li, 51, 4) \== '===>' then
call err 'bad headerline2' li
m.m.f2.lb = strip(substr(li, 43, 7))
if f3 == '' then
vv = strip(substr(li, 56, 20))
else
vv = strip(substr(li, 56, 2))
if m.m.f2 <> vv then
call err f2 m.m.f2.lb':' m.m.f2 '<>' vv
if f3 \== '' then do
if substr(li, 67, 2) \== '=>' then
call err 'bad headerline3' li
m.m.f3.lb = strip(substr(li, 61, 6))
if f3 = 'WH' then
m.m.f3 = strip(substr(li, 70, 10))
else if m.m.f3 <> strip(substr(li, 70, 10)) then
call err f3 m.m.f3.lb':' m.m.f3 '<>' strip(substr(li,70,10))
end
/* if f3 == '' then
say f1 m.m.f1.lb'='m.m.f1',' f2 m.m.f2.lb'='m.m.f2'|'
else
say f1 m.m.f1.lb'='m.m.f1',' f2 m.m.f2.lb'='m.m.f2',' ,
f3 m.m.f3.lb'='m.m.f3'|'
*/ return
endProcedure anaHLine
/*--- analyze edit Content extract selection SQL etc. ---------------*/
anaEditSql: procedure expose m.
parse arg m
m.m.rz = sysvar(sysnode)
m.m.user = userid()
call adrIsp 'VGET (zScreen )'
m.m.screen = zScreen
call adrEdit "(cL cC) = cursor"
m.m.cursor = cL
call adrEdit "(lxLa) = lineNum .zl"
sq = '' /* get sql etc. from trailer */
m.m.sql.0 = 0
m.m.path = ''
m.m.dbSy = ''
do lx=lxLa by -1 to 1
call adrEdit "(li) = line" lx
li = strip(li)
if word(li, 1) = 'order' then
m.m.sqlOrd = li
else if word(li, 1) = 'path:' then
m.m.path = subWord(li, 2)
else if word(li, 1) = 'dbSys:' then do
m.m.dbSy = subWord(li, 2)
leave
end
else do
sq = li sq
if word(li, 1) = 'from' then do
call mAdd m'.SQL', strip(sq)
sq = ''
end
end
end
m.m.sqlSta = sq
if lx < 1 | m.m.path == '' | m.m.dbSy == '' then
call err 'path:' m.m.path 'or dbSys' m.m.dbSy 'not found'
m.m.table = tkrTable(, word(m.m.path, 1))
pf3 = 'PF3 = zurück zu rcQuery'
laMa = 'cx'
do lx=1 to min(lxLa, 3)
call adrEdit '(li) = line' lx
if word(li, 1) \== '*' | pos('help', li) < 1 ,
| wordPos('PF3', li) < 1 then
iterate
li = strip(substr(strip(li), 2))
laMa = word(li, 1)
if pos('?', laMa) > 0 then
laMa = left(laMa, pos('?', laMa)-1)
cx = pos('PF3', li)
cy = pos(',', li, cx)
if cy > cx then
pf3 = substr(li, cy, cy-cx)
else
pf3 = strip(substr(li, cx))
leave
end
if \ abbrev(translate(laMa), 'R') then
laMa = laMa word(m.m.path, 1)
m.m.help = ' *' m.cmd '? = help,' ,
'UNDO = zurück zu' laMa',' pf3
return
endProcedure anaEditSql
/*--- ana edit content extract data from list
for 1Plus key in table
if all then all lines else only cursor line ----------------*/
anaEditList: procedure expose m.
parse arg m, all
l = m'.LST'
tb = m.m.table
al = m.tb.alias
ky = tkrKey( , al'.1plus', '')
if ky == '' then do
ky = tkrKey( , al'.db', '')
if ky == '' then
ky = m.tb.pKey
end
m.l.key = ky
m.l.alias = al
return anaEditListKey(m, all, tkrKey(,ky), l)
endProcedure anaEditList
/*--- extract columns from tkrKey ky to list l ----------------------*/
anaEditListKey: procedure expose m.
parse arg m, all, ky, l
call adrEdit 'cursor = .zf'
do forever /* search title line */
if 0 <> adrEdit('find - 1 40', 0 4) then
call err 'could not find title: find first - 1 40'
call adrEdit '(ex cx) = cursor'
call adrEdit '(ti) = line' ex
tiSx = pos(' ', ti)
if tiSx > 0 & tiSx > pos('-', ti) then
leave
end
m.l.0 = 0
if abbrev(ti, '--- row 1 ---') then do /* c1 display in colMode */
if all then do
call adrEdit 'cursor = 1 0'
do rx=1 while adrEdit("find '--- row ' 1", 0 4) = 0
call adrEdit "(ex cx) = cursor"
call adrEdit "(li) = line .zCsr"
call anaEditColMode l, ky, ex
end
end
else
call anaEditColMode l, ky, ex
end
else do /* cx display in tableMode */
t1 = strip(ti, 't')
do vy=length(t1) by -1 to 1 while substr(t1, vy, 1) == '-'
end
if vy < 10 then
call err 'no labels found in title' t1
vx = lastPos('-', t1, vy) + 1
if substr(t1, vx, vy+1-vx) \== 'caxIdKeys' then
call err 'last col <> caxIdKeys:' t1
vl = words(vt)
call adrEdit "find last '"left(t1, 40)"' 1"
call adrEdit "(ty cy) = cursor"
ey = ty
if ey <= ex then
call err 'no trailer line found:' left(t1, 40)
if \ all then do
if m.m.cursor <= ex | m.m.cursor >= ey then
call err 'i}cursor line' m.m.cursor ,
'not between header' ex 'and trailer' ey 'lines'
ex = m.m.cursor - 1
ey = m.m.cursor + 1
end
sep = sqlCatTbVLsep() /* cycle lines and caxIdKeys title */
m.m.caxIdTit.0 = ''
cx = 0
do ly=ty+1
call adrEdit '(li) = line' ly
if left(li, 70) = '' | 'DBSYS:' == translate(word(li,1)) then
leave
cx = cx + 1
li = strip(li, 't')
if lastPos(' ', li) > vx then do
if m.m.caxIdTit.0 \== '' then
call err 'duplicate cycle caxIdKeys:' li
call caxIdAnaTit m'.CAXIDTIT', substr(li, vx), sep
li = left(li, vx-1)
end
m.m.cyc.cx = translate(strip(li, 't'))
end
m.m.cyc.0 = cx
if cx < 1 then
call err 'no cycle trailer lines found'
if m.m.caxIdTit.0 == '' then
call err 'no cycle caxIdKeys'
do tx = 1 to m.ky.0
co = m.ky.tx.col
f.tx.fld = tx
do qx=1 to m.m.caxIdTit.0 while m.m.caxIdTit.qx <> co
end
if qx <= m.m.caxIdTit.0 then do
f.tx.pos = - qx
end
else do
do cy=1 to cx
wx = wordPos(co, m.m.cyc.cy)
if wx > 0 then
leave
end
if wx < 1 then
call err 'column' co 'not found in cycle trailer'
wx = wordIndex(m.m.cyc.cy, wx)
cz = 1 + (cy // cx)
lz = substr(m.m.cyc.cz, wx)
wy = wordIndex(lz, 2 - abbrev(lz, ' ')) - 1
if wy < 1 then
wy = 1 + length(t1) - wx
f.tx.pos = wx
f.tx.len = wy
end
end
lx = 0
do ex=ex+1 to ey-1 /* each cx line */
call adrEdit '(li) = line' ex
li = strip(li, 't')
call caxIdAnaData m'.CAXIDDATA', m'.CAXIDTIT',
, substr(li, vx), sep
lx = lx + 1
do tx = 1 to m.ky.0
if f.tx.pos == '' then
m.l.lx.tx = ''
else if f.tx.pos > 0 then
m.l.lx.tx = strip(substr(li, f.tx.pos, f.tx.len))
else do
qx = - f.tx.pos
m.l.lx.tx = m.m.caxIdData.qx
end
m.l.lx.99 = ''
end
m.l.0 = lx
end /* each cx line */
end /* cx display */
return l
endProcedure anaEditListKey
caxIdAnaTit: procedure expose m.
parse arg m, src, sep
cx = 0
sx=1
do while sx < length(src) - 2
if substr(src, sx, length(sep)) \== sep then
call err 'caxId sep missing @'sx':' src
sy = pos(' 'sep, src, sx+4)
if sy <= sx then
call err 'caxId ending sep missing @'sx':' src
rst = substr(src, sx+4, sy-sx-4)
sx = sy+1
parse var rst ty':'rst
cx = cx + 1
m.m.cx = ':'strip(ty)
do while rst \== ''
parse var rst col '/' rst
cx = cx + 1
m.m.cx = strip(col)
end
end
if substr(src, sx) \== sep then
call err 'caxId bad emd @'sx':' src
m.m.0 = cx
return
endProcedure caxIdAnaTit
caxIdAnaData: procedure expose m.
parse arg m, tit, src, sep
cx = 0
sx=1
do while sx < length(src) - 2
if substr(src, sx, length(sep)) \== sep then
call err 'caxId sep missing @'sx':' src
sy = pos(' 'sep, src, sx+4)
if sy <= sx then
call err 'caxId ending sep missing @'sx':' src
rst = substr(src, sx+4, sy-sx-4)
sx = sy+1
parse var rst ty':'rst
cx = cx + 1
if m.tit.cx \== ':'strip(ty) then
call err 'caxId ty='ty 'not' m.tit.cx 'in' src
do while rst \== ''
parse var rst col '/' rst
cx = cx + 1
m.m.cx = col
end
end
if substr(src, sx) \== sep then
call err 'caxId bad emd @'sx':' src
if m.tit.0 \== cx then
call err 'caxId' cx 'elements not' m.tit.0 'in' src
return
endProcedure caxIdAnaTit
/*--- analyze one row in colMode format: 1 line per column ----------*/
anaEditColMode: procedure expose m.
parse arg l, ky, ex
lx = m.l.0 + 1
needed = left('1234565789ABCDEFGHIJKLMN', m.ky.0, 'x')
do ex=ex+1 until needed = ''
call adrEdit "(li) = line" ex
li = strip(li, 't')
if abbrev(li, '--- row ') | abbrev(li, '--- end of ') then
leave
liCo = translate(word(li, words(left(li, 30))))
do tx=1 to m.ky.0
if liCo = m.ky.tx.col then do
needed = overlay(' ', needed, tx)
if datatype(substr(li, 31, 12), 'n') ,
& datatype(substr(li, 43), 'n') then
m.l.lx.tx = strip(substr(li, 43))
else
m.l.lx.tx = substr(li, 31)
end
end
end
if needed <> '' then
call err 'needed' needed "<> '', tb" tb 'line' ex
m.l.lx.99 = ''
m.l.0 = lx
return
endProcedure anaEditColMode
listDef: procedure expose m.
parse arg l, list
if m.l.lp.alias == '' then
call err 'listDef with empty lp.alias, type='m.l.type
tParts = 0 < wordPos('tp', list) + wordPos('ip', list)
tObjs = 0 < wordPos('ts', list) + wordPos('i', list)
if m.l.lp.alias = 'tp' then do
if tParts then do
if m.l.alias == 'rc' then do
if m.l.tpNo.0 <> 0 then do
call out ' -- ignoring objects because of fun'
do lx=1 to m.l.tpNo.0
call out ' --' m.l.tpNo.lx
end
end
call listDef1 l'.TPRC', tpRc, 'TABLESPACE', 'PARTLEVEL'
if m.l.tpRc.0 = 0 then
call out ' INCLUDE TABLESPACE DOESNOT.EXIST*'
end
call listDef1 l'.LP', tp, 'TABLESPACE', 'PARTLEVEL'
if wordPos('ip', list) > 0 then
call out ' LISTDEF IPLIST INCLUDE INDEXSPACES' ,
'LIST TPLIST'
if wordPos('ip', list) > 0 m..tpRc.0 <> 0 then
call out ' LISTDEF IPRCLIST INCLUDE INDEXSPACES' ,
'LIST TPRCLIST'
end
if tObjs then do
call listDef1 l'.LO', ts, 'TABLESPACE'
if wordPos('i', list) > 0 then
call out ' LISTDEF ILIST INCLUDE INDEXSPACES' ,
'LIST TPLIST'
end
end
else if m.l.lp.alias == 'ip' then do
if tParts then do
call listDef1 l'.LP', ip, 'INDEX', 'PARTLEVEL'
if wordPos('tp', list) > 0 then
call out ' LISTDEF TPLIST INCLUDE TABLESPACES' ,
'LIST IPLIST'
end
if tObjs then do
call listDef1 l'.LO', i, 'INDEX'
if wordPos('ts', list) > 0 then
call out ' LISTDEF TSLIST INCLUDE TABLESPACES' ,
'LIST ILIST'
end
end
else
call err 'listDef no objs found'
return
endProcedure listDef
listdef1: procedure expose m.
parse arg l, ld, sp, pa
call out ' LISTDEF' ld'LIST'
t2 = ''
do lx=1 to m.l.0
if pa \== '' then
t2 = 'PARTLEVEL' m.l.lx.3
call out ' INCLUDE' sp m.l.lx.1'.'m.l.lx.2 t2
end
return
endProcedure listDef1
listExp: procedure expose m.
parse arg l
m.l.lp.alias = ''
m.l.lp.0 = 0
m.l.lo.0 = 0
tF = m.l.alias
if wordPos(tF, 'co tp rc') > 0 then
ii = 'tp 1 2 3'
else if tF == 'rt' then
ii = 'tp 5 6 3'
else if tF == 'ts' then
ii = 'tp 1 2 99'
else if tF == 't' then
ii = 'tp 3 4 99'
else if wordPos(tF, 'is ip ri') > 0 then
ii = 'ip 1 2 3'
else if wordPos(tF, 'i ik') > 0 then
ii = 'ip 1 2 99'
else
return l
m.l.colInfo = ii
if tF == 't' then
m.l.colTb = 1 2
else
m.l.colTb = ''
parse var ii m.l.lp.alias f1 f2 f3
xp = 0
xo = 0
xR = 0
xL = 0
xN = 0
drop done.
do lx=1 to m.l.0
v1 = m.l.lx.f1
v2 = m.l.lx.f2
v3 = m.l.lx.f3
if done.v1.v2.v3 == 1 then
iterate
done.v1.v2.v3 = 1
xp = xp + 1
m.l.lp.xp.1 = v1
m.l.lp.xp.2 = v2
m.l.lp.xp.3 = v3
if tF = 'rc' then do
if translate(m.l.lx.4) = 'R' then do
xR = xR + 1
m.l.tpRc.xR.1 = v1
m.l.tpRc.xR.2 = v2
m.l.tpRc.xR.3 = v3
end
else if translate(m.l.lx.4) = 'L' then do
xL = xL + 1
m.l.tpLo.xL.1 = v1
m.l.tpLo.xL.2 = v2
m.l.tpLo.xL.3 = v3
end
else do
xN = xN + 1
m.l.tpNo.xN = v1'.'v2':'v3 'fun='m.l.lx.4
end
end
if done.v1.v2 == 1 then
iterate
done.v1.v2 = 1
xo = xo + 1
m.l.lo.xo.1 = v1
m.l.lo.xo.2 = v2
end
m.l.lp.0 = xp
m.l.lo.0 = xo
m.l.tpLo.0 = xL
m.l.tpNo.0 = xN
m.l.tpRc.0 = xR
m.l.lpRc.0 = xR
if tF = 'rc' then
m.l.lpRc = tpRc
else
m.l.lpRc = m.l.lp.alias
return l
endProcedure listExp
listSelect: procedure expose m.
parse arg m, l, o, ky, pa
tb = m.ky.table
al = m.tb.alias
if m.l.alias == al then do
do kx=1 to m.ky.0
c1 = m.ky.kx.col
do ox=1 to m.l.0
m.o.ox.c1 = m.l.ox.kx
end
end
m.o.0 = m.l.0
return o
end
sq = 'select' m.ky.colList tkrTable(, tb, 'f') ,
tkrWhere(, al pa m.l.alias':' ,
list2where(l, tkrKey(, m.l.alias'.1')))
call sqlconnect m.m.dbSy
call sql2St sq, o
call sqlDisconnect
return o
endProcedure listSelect
list2where: procedure expose m.
parse arg l, aKey
tb = m.aKey.table
al = m.tb.alias
drop done.
done = ''
do lx=1 to m.l.0
k2 = ''
do tx=1 to m.aKey.0-1
k2 = k2'.'m.l.lx.tx
end
k2 = substr(k2, 2)
ty = m.aKey.0
ky = k2'.'m.l.lx.ty
vy = tkrValue( , , m.aKey.ty, m.l.lx.ty)
if done.ky == 1 then
iterate
done.ky = 1
dx = wordPos(k2, done)
if dx > 0 then do
done.dx = done.dx"," vy
end
else do
done = done k2
dx = wordPos(k2, done)
s1 = ''
do tx=1 to m.aKey.0-1
s1 = s1 tkrPred( , , m.aKey.tx, m.l.lx.tx)
end
done.dx = substr(s1, 6) 'and' m.aKey.ty "in ("vy
end
end
wh = ''
do dx = 1 to words(done)
wh = wh 'or ('done.dx'))'
end
return '('substr(wh, 5)')'
endProcedure list2where
/*--- generate job with all requeste utilities ----------------------*/
genJob: procedure expose m.
parse arg m, l, ty, parms
m.m.rand = right(time(), 2) // 20
m.m.jn = m.m.user || substr(m.ut_UC, m.m.rand+7, 1)
call out "//"m.m.jn "JOB (CP00,KE50),'DB2" parms"',"
call out "// TIME=1440,REGION=0M,SCHENV=DB2ALL" ,
|| ",CLASS=M1,"
call out "// MSGCLASS=T,NOTIFY=&SYSUID"
call out "//*"
call out "//* ux utility generator" parms
call out "//* who" m.m.rz m.m.dbSy m.m.user m.m.screen
call out "//* " translate(date('E'), '.', '/') time() ,
m.m.jn
call out "//*"
inStep = ''
m.m.stepNo = 0
pa2 = '' /* get unique utilNames */
uts = 'co=COPY re=REORG rb=REBIND rb=RBIND rc=RECOVER rc=RCOVER' ,
'ru=RUNSTATS bu=REBUILD bu=BUILD un=UNLOAD' ,
'ld=LOADDUMMY ld=LOADUMMY ld=LDUMMY ld=DUMMY',
'cd=CDATA cd=CHECKDATA',
'ce=CEXCEPTIONTABLES ce=CHECKEXCEPTIONTABLES',
'ce=CHECKDATAEXCEPTIONTABLES' ,
'ci=CINDEX ci=CHECKINDEX'
do ux=1 to words(parms)
cx = pos('='translate(word(parms, ux)), uts)
if cx <= 2 then
call err 'bad utility parm' word(parms, ux) 'in' parms, 'S'
pa2 = pa2 substr(uts, cx-2, 2)
end
/* new runstats: explicit with profile */
m.m.statsProf = wordPos(sysvar(sysnode), 'RZX RZY') > 0
if m.m.statsProf & pos('ru', pa2) < 1 then do
rx = max(lastPos('re', pa2), lastPos('ld', pa2))
if rx > 0 then
pa2 = insert(' ru', pa2, rx+1)
end
lst = '' /* which listDefs are needed? */
if wordPos('co', pa2) > 0 | wordPos('re', pa2) > 0 then
lst = lst 'tp'
if wordPos('rc', pa2) > 0 then
lst = lst 'tp' copies('tpRc tpLo', m.l.alias = 'rc')
if wordPos('ru', pa2) > 0 | wordPos('un', pa2) > 0 then
lst = lst 'ts'
if wordPos('bu', pa2) > 0 | wordPos('ci', pa2) > 0 then
lst = lst 'ip'
call listExp l
lstSuf = 'LIST'
if wordPos('rc', pa2) > 0 then
if m.l.alias <> 'rc' then
call warnXDocs m, l
m.m.prodOut = m.m.rz = 'RZ2' & (wordPos('rc', pa2) > 0 ,
| wordPos('ld', pa2) > 0 | wordPos('bu', pa2) > 0)
m.m.prodMark = left(copies('?', m.m.prodOut), 1)
if m.m.prodOut then do
call out left("//* >>> Attention possible production outage ",
, 80, '<')
call out "//* check utilities"
call out "//* remove '?' before utilities only if ok"
call out "//*"
end
do ux=1 to words(pa2) /* now, generate each utility */
u1 = word(pa2, ux)
if wordPos(u1, 'bu co ld re rc ru un cd ce ci') > 0 then do
if inStep \== 'ut' then do
inStep = 'ut'
call genUtil m
if lst \== '' then
call listdef l, lst
end
if u1 == 'bu' then
call genBuild m, lstSuf
else if u1 == 'cd' | u1 = 'ce' then
call genCheckData m, l, u1
else if u1 == 'ci' then
call genCheckIndex m
else if u1 == 'co' then
call genCopy m, lstSuf
else if u1 == 'ld' then
call genLoadDummy m, l'.LP',
, listSelect(m, l, tbPa, tkrKey(, 't.1plus'))
else if u1 == 'rc' then do
if m.l.alias <> 'rc' then do
call genRecover m, l, lstSuf
end
else do
if m.l.tpLo.0 <> 0 then
call genRecLoad m, l
lstSuf = 'RCLIST'
if m.l.tpRc.0 <> 0 then
call genRecover m, l, lstSuf
end
end
else if u1 == 're' then
call genReorg m
else if u1 == 'ru' then
call genRunstats m
else if u1 == 'un' then
call genUnload m, l
else
call err 'implement util' u1
end
else if u1 == 'rb' then do
pkl = m'.pkl'
call listSelect m, l, pkl, tkrKey(, 'pk.1plus'), 'ts'
call genDsn m
inStep = 'dsn'
do px=1 to m.pkl.0
if m.pkl.px.type = '' then
call out 'rebind package ('strip(m.pkl.px.collid) ,
|| '.'strip(m.pkl.px.name) ,
|| '.('strip(m.pkl.px.version)'))'
else if m.pkl.px.type = 'T' then
call out 'rebind trigger package(' ,
|| strip(m.pkl.px.collid)'.' ,
|| strip(m.pkl.px.name)')'
else
call err 'implement rebind of pk type' m.pkl.px.type
end
end
else
call err 'implement util' u1
end
return
endProcedure genJob
genBuild: procedure expose m.
parse arg m, liSu
call out left('---- rebuild index ', 72, '-')
call out m.m.prodMark "REBUILD INDEX LIST IP"liSu
call out " SORTDEVT SYSDA"
call out " STATISTICS UPDATE ALL"
return
endProcedure genBuild
/*--- check utility, for cE create exception tables -----------------*/
genCheckData: procedure expose m.
parse arg m, l, fu
if m.l.lp.alias <> 'tp' then
call err 'i}use checkData not from indexes'
call out left('---- checkData ', 72, '-')
call out " CHECK DATA"
do lx = 1 to m.l.lp.0
call out " TABLESPACE" m.l.lp.lx.1"."m.l.lp.lx.2 ,
if(m.l.lp.lx.3 \== "", "PART" m.l.lp.lx.3)
end
call out " SHRLEVEL REFERENCE"
call out " SCOPE ALL"
call out " EXCEPTIONS 0"
if fu == 'ce' then do
call out " FOR EXCEPTION"
uxDb = 'DB2$$$UX'
sq = ''
do lx = 1 to m.l.lo.0
if oldDb \== m.l.lo.lx.1 then do
oldDb = m.l.lo.lx.1
sq = sq")) or (t.dbName = '"oldDb"' and t.tsName in ("
end
else
sq = sq", "
sq = sq"'"m.l.lo.lx.2"'"
end
sq = "select t.creator, t.name, t.encoding_scheme, s.bPool",
"from sysibm.sysTables t" ,
"join sysibm.sysTableSpace s" ,
"on t.dbName = s.dbName and t.tsName = s.name" ,
"where t.type not in('A', 'V')" ,
"and ("substr(sq, 7)")))"
call sqlconnect m.m.dbSy
o = m'.tb'
call sql2St sq, o
call sqlExImm "set current sqlid = 'S100447'"
if sql2One("select name from sysibm.sysDatabase" ,
"where name = '"uxDb"'", 'uxDB', '') ,
\== uxDb then do
call sqlExImm "create database" uxDB ,
"BUFFERPOOL BP2 INDEXBP BP1 STOGROUP GSMS"
call sqlCommit
say 'db' uxDb 'created'
end
ts = sql2One("select value(max(name), '$$$00000')" ,
"from sysibm.sysTablespace where dbname = '"uxDb"'")
do ox=1 to m.o.0
if left(ts, 3) \== '$$$' | \ datatype(substr(ts, 4), 'n'),
then call err 'bad ts' ts
ts = left(ts, 3) || right('00000' || (1+substr(ts, 4)), 5)
call sqlExImm "create tablespace" ts "in" uxDB ,
"segsize 64 bufferpool" m.o.ox.bPool ,
"compress yes maxRows 255 ccsid",
if(m.o.ox.encoding_scheme=='E','EBCDIC','UNICODE')
cr = "$UX$"strip(m.o.ox.creator)"$"
tb = "$UX$"strip(m.o.ox.name)"$"
call out " IN " strip(m.o.ox.creator) ,
|| "."strip(m.o.ox.name)
call out " USE" cr"."tb
do forever
sc = sqlExImm("create table" cr"."tb ,
"like" m.o.ox.creator"."m.o.ox.name ,
"including identity" ,
"in" uxDb"."ts, -601)
if sc = 0 then do
say 'created table' cr'.'tb 'in' uxDb'.'ts
leave
end
oldTs = sql2one("select strip(dbName) || '.' ||" ,
"strip(tsName) from sysibm.sysTables",
"where creator = '"cr"' and name = '"tb"'")
say 'table' cr'.'tb 'already exists in' oldTs
if substr(ans, 2, 1) \== 'A' then do
say 'Use old table, Drop tableSpace, Exit?' ,
'(u/d/e +a for all)'
parse upper pull ans .
end
if abbrev(ans, 'U') then do
call sqlExImm "drop tableSpace" uxDb"."ts
say "dropped tableSpace" uxDb"."ts
leave
end
if \ abbrev(ans, 'D') then
call err 'table' cr'.'tb 'already exists in' oldTs
call sqlExImm "drop tableSpace" oldTs
say "dropped tableSpace" oldTs
call sqlCommit
end
call sqlCommit
end
call out " DELETE NO -- YES LOG YES"
call sqlDisconnect
end
call out " WORKDDN(TSYUTS, TSOUTS) ERRDDN TERRD"
call out " SORTDEVT DISK"
return
endProcedure genCheckData
genCheckIndex: procedure expose m.
parse arg m, l, fu
call out left('---- checkIndex ', 72, '-')
call out " CHECK INDEX LIST IPLIST"
call out " SHRLEVEL REFERENCE"
call out " SORTDEVT DISK"
return
endProcedure genCheckIndex
genCopy: procedure expose m.
parse arg m, liSu
call out left('---- copy ', 72, '-')
call out " COPY LIST TP"liSu "COPYDDN(TCOPYD)"
call out " FULL YES"
call out " PARALLEL"
call out " SHRLEVEL CHANGE"
return
endProcedure genCopy
genLoadDummy: procedure expose m.
parse arg m, lp, l
if m.lp.alias \== 'tp' then
call err 'loadDummy for' m.lp.alias
ts = ''
drop ts. tb.
do px=1 to m.lp.0
ky = strip(m.lp.px.1)'.'strip(m.lp.px.2)
if symbol('ts.ky') \== 'VAR' then do
ts.ky = ''
tb.ky = ''
ts = ts ky
end
if m.lp.px.3 <> '' then
ts.ky = overlay('p', ts.ky, m.lp.px.3)
kt =
end
do lx=1 to m.l.0
ky = strip(m.l.lx.dbName)'.'strip(m.l.lx.tsName)
kt = strip(m.l.lx.creator)'.'strip(m.l.lx.name)
if symbol('ts.ky') \== 'VAR' then
call err 'ts' ky 'for t' kt 'not in part list'
if wordPos(kt, tb.ky) < 1 then
tb.ky = tb.ky kt
end
rSp = " RESUME NO REPLACE COPYDDN(TCOPYS) INDDN INDUMMY"
do tx=1 to words(ts)
ky = word(ts, tx)
call out left('---- load dummy' ky, 72, '-')
if symbol('tb.ky') \== 'VAR' then
call err 'no table in ts' ky
call out m.m.prodMark "LOAD DATA LOG NO"
call out " WORKDDN(TSYUTS, TSOUTS) MAPDDN TMAPD"
call out " STATISTICS INDEX(ALL) REPORT NO UPDATE ALL"
ps = ts.ky
if ps = '' then do
call out rSp
do qx=1 to words(tb.ky)
call out " INTO TABLE" word(tb.ky, qx)
end
end
else do
t1 = strip(tb.ky)
if words(t1) <> 1 then
call err 'multiple tables' t1 'in partitioned TS'
do while ps <> ''
px = pos('p', ps)
ps = overlay(' ', ps, px)
call out " INTO TABLE" t1 'PART' px
call out rSp
end
end
end
return
endProcedure genLoadDummy
/*--- generate recover statement, with hints for useful RBAs -------*/
genRecover: procedure expose m.
parse arg m, l, liSu
minRba = 'FFFFFFFFFF'
maxRba = '00'
minPit = 'FFFFFFFFFF'
maxPit = '00'
dsn = ''
cDsn = 0
rDsn = '?.? DSNUM ?'
if m.l.alias == 'co' then do
ky = tkrKey(, 'co.1plus')
fty = wordPos('co.icType,', m.ky.colList',')
fRba = wordPos('co.start_Rba,', m.ky.colList',')
fPit = wordPos('co.pit_Rba,', m.ky.colList',')
fDsn = wordPos('co.dsName,', m.ky.colList',')
do lx=1 to m.l.0
if pos(left(m.l.lx.fTy, 1), 'FI') > 0 then do
cDsn = cDsn + 1
dsn = m.l.lx.fDsn
rDsn = m.l.lx.1'.'m.l.lx.2
if m.l.lx.3 <> '' then
rDsn = rDsn 'DSNUM' m.l.lx.3
end
if x2c(minRba) >> x2c(m.l.lx.fRba) then
minRba = m.l.lx.fRba
if x2c(maxRba) << x2c(m.l.lx.fRba) then
maxRba = m.l.lx.fRba
if m.l.lx.fPit \= '000000000000' then do
if x2c(minPit) >> x2c(m.l.lx.fPit) then
minPit = m.l.lx.fPit
if x2c(maxPit) << x2c(m.l.lx.fPit) then
maxPit = m.l.lx.fPit
end
end
end
call out left('---- recover ', 72, '-')
call out '-- Tipp: mit TSO LRSN logPoints umwandeln'
call out m.m.prodMark 'RECOVER LIST TP'liSu
call out ' PARALLEL'
if maxPit = '00' then nop
else if maxPit = minPit then
call out "-- TOLOGPOINT X'"maxPit"' -- pit_rba"
else do
call out "-- TOLOGPOINT X'"maxPit"' -- max pit_rba"
call out "-- TOLOGPOINT X'"minPit"' -- min pit_rba"
end
if maxPit \= '00' & maxRba = '00' then nop
else if maxRBA = minRBA then
call out "-- TOLOGPOINT X'"maxRBA"' -- start_rba"
else do
call out "-- TOLOGPOINT X'"maxRBA"' -- max start_rba"
call out "-- TOLOGPOINT X'"minRBA"' -- min start_rba"
end
call out '-- LOGONLY BACKOUT YES'
call out '-- RESTOREBEFORE' minRba
call out '-- TOLASTCOPY'
call out '-- TOLASTFULLCOPY'
call out '--RECOVER TABLESPACE' rDsn
call out '-- TOCOPY' dsn
if cDsn > 1 then
call out ' -- Achtung' cDsn 'copies|'
return
endProcedure genRecover
/*--- generate load for each partition with rc.fun='l' --------------*/
genRecLoad: procedure expose m.
parse arg m, l
if m.l.alias \== 'rc' then
call err 'genRecLoad ohne alias rc'
ky = tkrKey(, 'rc.1plus')
fFun = wordPos('rc.fun,' , m.ky.colList',')
fRec = wordPos('rc.recover,' , m.ky.colList',')
fbas = wordPos('rc.basPTT,' , m.ky.colList',')
fLoa = wordPos('rc.loadText,', m.ky.colList',')
fUts = wordPos('rc.unlTst,' , m.ky.colList',')
fUnl = wordPos('rc.unl,' , m.ky.colList',')
fPTs = wordPos('rc.punTst,' , m.ky.colList',')
fPun = wordPos('rc.pun,' , m.ky.colList',')
fTb = wordPos('rc.tb,' , m.ky.colList',')
/* m, mRc, '1plus', 'db ts pa recFun recover',
'basPTT load unlTst unl punTst pun tb'
*/
ty = 0
do forever
do tx=1 to m.l.0
if translate(m.l.tx.fFun) <> 'L' then
iterate
aTb = strip(m.l.tx.fTb)
if done.aTb <> 1 then
leave
end
if tx > m.l.0 then
leave
done.aTb = 1
ty = ty + 1
call out '-- templates for table' ty aTb
do lx=tx to m.l.0
if translate(m.l.lx.fFun) <> 'L' | aTb <> m.l.lx.fTb then
iterate
call out ' TEMPLATE T'ty'P'm.l.lx.3
call out " DSN('"strip(m.l.lx.fUnl)"')"
end
call out '-- loading table' ty aTb
call out m.m.prodMark 'LOAD DATA LOG NO'
call out ' STATISTICS INDEX(ALL) REPORT NO UPDATE ALL'
call out ' SORTKEYS SORTDEVT DISK'
call out ' WORKDDN(TSYUTD,TSOUTD)'
do lx=tx to m.l.0
if translate(m.l.lx.fFun) <> 'L' | aTb <> m.l.lx.fTb then
iterate
call out ' -- part ' m.l.lx.1'.'m.l.lx.2':'m.l.lx.3
call out ' -- recov?' m.l.lx.fRec m.l.lx.fBas
call out ' -- unloa?' m.l.lx.fLoa
call out ' -- unload' m.l.lx.fUnl m.l.lx.fUTs
call out ' -- punch ' m.l.lx.fPun m.l.lx.fPts
call out ' INTO TABLE' m.l.lx.fTb 'PART' m.l.lx.3
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)'
call out ' INDDN T'ty'P'm.l.lx.3
s = jOpen(scanUtilReset(ScanRead(file(m.l.lx.fPun))), '<')
if \ scanUtilInto(s) then
call scanErr s, 'no load into' m.l.lx.fPun
call out '--end utilInto' m.s.tb m.s.part
if m.s.tb <> m.l.lx.fTb then
call err 'punch tb' m.s.tb '<>' m.l.lx.fTb ,
'in' m.l.lx.fPun
call jClose s
end
end
return
endProcedure genRecLoad
warnXDocs: procedure expose m.
parse arg m, l
XDoc = ''
if m.l.lp.alias <> 'tp' then
call err 'lp.alias' m.l.lp.alias
do px=1 to m.l.lp.0 while XDoc == ''
db = m.l.lp.px.1
ts = m.l.lp.px.2
if db = 'XC01A1P' ,
& ( abbrev(ts, 'A200A') ,
| ts = 'A501A' | ts = 'A502A' ,
) then
XDoc = 'XC'
else if db = 'XR01A1P' then
XDoc = 'XR'
else if left(db, 2) = 'XB' then
XDoc = 'XB'
else if db = 'QZ01A1P' & ts = 'A004A' then
XDoc = 'qzTest'
end
if xDoc \== '' then do
call out left('//* >>> Attention:' XDoc ,
'Documents, besser aus CX RC recovern ', 80, '<')
call out '//*'
end
return
endProcedure warnXDocs
genReorg: procedure expose m.
parse arg m
call out left('---- reorg ', 72, '-')
call out ' REORG TABLESPACE LIST TPLIST'
call out ' LOG NO'
call out ' SORTDATA'
call out ' COPYDDN(TCOPYD)'
call out ' SHRLEVEL CHANGE'
/*
call out ' -- Achtung mapping table' ,
'zufällig gewählt|'
call out ' MAPPINGTABLE S100447.MAPTAB'm.m.rand2
if wordPos(sysvar(sysnode), 'RZ2 RR2') < 1 then
call out ' MAPPINGDATABASE QZMAPTB' ...
*/
call out ' DRAIN_WAIT 20'
call out ' RETRY 20 '
call out ' RETRY_DELAY 180'
call out ' MAXRO 20 '
call out ' DRAIN ALL'
call out ' LONGLOG CONTINUE'
call out ' DELAY 600'
call out ' TIMEOUT TERM'
call out ' UNLDDN TSRECD'
call out ' UNLOAD CONTINUE'
call out ' PUNCHDDN TPUNCH'
call out ' DISCARDDN TDISC'
call out ' SORTKEYS'
call out ' SORTDEVT DISK'
call out ' STATISTICS'
call out ' INDEX ALL KEYCARD '
call out ' UPDATE ALL'
return
endProcedure genCopy
genRunstats: procedure expose m.
parse arg m
call out left('---- runstats ', 72, '-')
call out " RUNSTATS TABLESPACE LIST TSLIST"
call out " SHRLEVEL CHANGE "
if m.m.statsProf then do
call out " TABLE USE PROFILE"
call out " TABLESAMPLE SYSTEM AUTO"
end
else do
call out " INDEX(ALL)"
end
return
endProcedure genRunstats
genUnload: procedure expose m.
parse arg m, l
if m.l.lp.alias <> 'tp' then
call err 'i}use unload not from indexes'
call out "TEMPLATE TREC -- UNLDDN fuer Unload"
call out " DSN('&SSID..&DB..&SN..P&PART..D&YE(3).&MO.&DA..REC')"
call out " DATACLAS(ENN35) MGMTCLAS(COM#A032)"
call out " SPACE TRK MAXPRIME 600"
call out "TEMPLATE TPUN -- PUNCHDDN fuer reorg unload"
call out " DSN('&SSID..&DB..&SN..P&PART..D&YE(3).&MO.&DA..PUN')"
call out " DATACLAS(NULL8) MGMTCLAS(COM#A032)"
call out " SPACE(1,10) TRK"
parse var m.l.colInfo . dbX tsX .
parse var m.l.colTb crX tbX .
do tx=1 to m.l.0
dbTs = m.l.tx.dbX'.'m.l.tx.tsX
crTb = m.l.tx.crX'.'m.l.tx.tbX
if done.dbTs.qq.crTb == 1 then
iterate
done.dbTs.qq.crTb = 1 then
call out "UNLOAD TABLESPACE" dbTs '-- PART 7:8'
call out "-- UNLOAD LIST TSLIST"
call out " -- FROM COPY" m.m.dbSy"."dbTs".P00001..."
call out " UNLDDN TREC PUNCHDDN TPUN EBCDIC NOPAD"
call out " SHRLEVEL CHANGE ISOLATION CS -- SKIP LOCKED DATA"
if crTs <> '.' then
call out " FROM TABLE" crTb
/* iterate
aTb = strip(m.l.tx.fTb)
if done.aTb <> 1 then
leave
*/ end
return
endProcedure genUnload
genUtil: procedure expose m.
parse arg m
m.m.stepNo = m.m.stepNo + 1
call out left("//STEP"m.m.stepNo , 10),
"EXEC PGM=DSNUTILB,TIME=1440,"
call out "// PARM=("m.m.dbSy",'"m.m.jn".UXUTIL'),"
call out "// REGION=0M"
call out "//SYSPRINT DD SYSOUT=*"
call out "//*YSPRINT DD DSN=DSN.JOBRUN."m.m.jn ,
|| ".STEP"m.m.stepNo".#DT#,"
j = left('//*', 15)
call out j"DISP=(NEW,CATLG,CATLG),MGMTCLAS=BAT#NW,DSNTYPE=LARGE,"
call out j"DCB=(RECFM=FB,LRECL=132,DSORG=PS),SPACE=(CYL,(1,1000))"
call out "//SYSUDUMP DD SYSOUT=*"
call out "//SYSTEMPL DD DISP=SHR,DSN="m.m.dbSy ,
|| ".DBAA.LISTDEF(TEMPL)"
call out "//UTPRINT DD SYSOUT=*"
call out "//RNPRIN01 DD SYSOUT=*"
call out "//STPRIN01 DD SYSOUT=*"
call out "//INDUMMY DD DUMMY"
call out "//SYSIN DD *"
call out '-- OPTIONS PREVIEW'
return
endProcedure genUtil
genDSN: procedure expose m.
parse arg m
m.m.stepNo = m.m.stepNo + 1
call out "//STEP"m.m.stepNo ,
" EXEC PGM=IKJEFT01"
call out "//SYSTSPRT DD SYSOUT=*"
call out "//SYSPRINT DD SYSOUT=*"
call out "//SYSTSIN DD *"
call out "DSN SYS("m.m.dbSy")"
return
endProcedure genDsn
/* copy tkr begin ***************************************************
Table Key Relationship **************************************/
/*--- get tkrTable address -------------------------------------------
key: either address or name, initialise if necessary
fields:
alias
table creator.tablename alias
keys list of keySequences
rels list of relationships
pKey primary key
order list for sql order clause
cond sqlCondition for where
editFun special sqlCat function
vlKey key to put in variable length part in tab format
---------------------------------------------------------------------*/
tkrTable: procedure expose m.
parse arg m, key, wh
if m == '' then
m = tkr
dx = pos('.', key)
if dx < 1 then
mt = m'.t.'key
else
mt = key
if m.mt \== 't' then do
if m.mt \== 't?' then
if arg() >= 4 then
return arg(4)
else
call err 'not a table' key', mt' mt'->'m.mt
if m.m.initialising then
return mt
m.mt = 't' /* lazy initialise this table */
ty = m.mt.alias
if m.mt.pKey \== '' then
m.mt.pKey = tkrKey(m, m.mt.pKey)
if m.mt.vlKey \== '' then
m.mt.vlKey = tkrKey(m, ty'.'m.mt.vlKey)
if m.mt.order == '' then
m.mt.order = mCat(tkrKey(m, m.mt.pKey), ', ')
else if pos(',', m.mt.order) <1 & pos('.', m.mt.order) <1 then
m.mt.order = ty'.'repAll(space(m.mt.order, 1),
, ' ', ',' ty'.')
if m.mt.cond \== '' then
m.mt.cond = m.mt.cond 'and'
end
if wh == '' then
return mt
else if wh == 't' then
return m.mt.table
else if wh == 'o' then
return m.mt.order
else if wh == 'f' then
return 'from' m.mt.table 'where' m.mt.cond
else if wh == 'w' then
return m.mt.cond
else if wh == 'e' then
return m.mt.editFun
else
call err 'bad what' wh 'in tkrTable('m',' tb',' wh')'
endProcedure tkrTable
/*--- get key address for ky, initialise if necessary ---------------
ky either address or name
if table the primaryKey
fields:
table address of table
name name of rel
opt options i=has index, u=isUnique, 1=
colList list of columns in sql format (with alias)
keys.* stem of columns
= alias.column
.col column
---------------------------------------------------------------------*/
tkrKey: procedure expose m.
parse arg m, ky
if m == '' then
m = tkr
mt = tkrTable(m, ky, , '')
if mt \== '' then
mk = m.mt.pkey
else do
dx = pos('.', ky)
if dx <= 0 then
mk = ''
else if pos('.', ky, dx+1) <= 0 then
mk = m'.k.'ky
else
mk = ky
end
if m.mk == 'k' & mk \== '' then
return mk
if m.mk \== 'k?' | mk == '' then
if arg() >= 3 then
return arg(3)
else
return err('not a ky:' ky '->' mk)
if m.m.initialising then
return mk
m.mk = 'k'
tb = tkrTable(m, m.mk.table)
al = m.tb.alias
m.mk.0 = words(m.mk.colList)
do cx=1 to m.mk.0
c1 = word(m.mk.colList, cx)
dx = pos('.', c1)
if dx < 1 then do
m.mk.cx = al'.'c1
m.mk.cx.col = translate(c1)
end
else do
m.mk.cx = c1
m.mk.cx.col = translate(substr(c1, dx+1))
end
end
m.mk.colList = mCat(mk, ', ')
return mk
endProcedure tkrKey
/*--- get relationship address for ky -------------------------------
ky either address or name
initialise if necessary
fields
lef key address for left table
lef.sql1 additional sql
lef.cond additional sql condition
rig* analog for right table
---------------------------------------------------------------------*/
tkrRel: procedure expose m.
parse arg m, key
if m == '' then
m = tkr
if m.key == 'r' then
return key
mr = m'.r.'key
if m.mr == 'r' then
return mr
call err 'not a relationship' key'-->'m.key',' m.mr
endProcedure tkrRel
/*--- generate sql whereCondition for path pa
giving chain of where (...) in (select ... where ... ----------*/
tkrWhere: procedure expose m.
parse arg m, pa ':' wh
if m == '' then
m = tkr
pEx = tkrPath(m, pa)
m.m.path = pEx
sq = wh
do px=words(pEx)-1 by -1 to 1
tt = word(pEx, px)
tf = word(pEx, px+1)
if symbol('m.m.t2t.tt.tf') == 'VAR' then
parse value m.m.t2t.tt.tf 'LEF RIG' with rl fTo fFr
else if symbol('m.m.t2t.tf.tt') == 'VAR' then
parse value m.m.t2t.tf.tt 'RIG LEF' with rl fTo fFr
else
call err 'no relationShip to' tt 'from' tf 'path' pEx,
't.f' m.m.tt.tf 'f.t' m.m.tf.tt
call tkrKey m, m.rl.lef
call tkrKey m, m.rl.rig
if m.rl.fFr.sql1 \== '' then
sq = m.rl.fFr.sql1 sq')'
else do
kc = min(mGet(m.rl.lef'.'0), mGet(m.rl.rig'.'0))
sq = '('fCatFT(', ', m.rl.fTo, 1, kc)')' ,
'in (select' fCatFT(', ', m.rl.fFr, 1, kc),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')'
end
end
return sq
endProcedure tkrWhere
/*--- expand path sPA with all intermediate tables ------------------*/
tkrPath: procedure expose m.
parse arg m, sPa
res = word(sPa, 1)
do sx=2 to words(sPa)
p1 = tkrPat1(m, word(sPa, sx-1), word(sPa, sx))
if p1 == '' then
return err('no path to' word(sPa,sx-1) 'from' word(sPa,sx))
res = res subWord(p1, 2)
end
if m.debug then
say '???' sPa '==path==>' res
return res
endProcedure tkrPath
/*--- return path to tt from tf, fail if not unique ------------------*/
tkrPat1: procedure expose m.
parse arg m, tt, tf
m.m.pathRes.0 = 0
call tkrPat3 m, tt, tf
if m.m.pathRes.0 = 1 then
return m.m.pathRes.1
else if m.m.pathRes.0 < 1 then
return err('no path to' tt 'from' tf)
else if m.m.pathRes.0 > 1 then
return err('multiple ('m.m.pathRes.0') paths' tt'<-'tf':',
mCat(m'.'pathRes, ' <> '))
endProcedure tkrPat1
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat2: procedure expose m.
parse arg m, tt, tf
call tkrPat3 m, tt, tf
if m.debug then do
say '???' tt '<' tf '--pat2-->' m.m.pathRes.0 'paths'
do px=1 to m.m.pathRes.0
say '???'px'???' m.m.pathRes.px
end
end
return
endProcedure tkrPat2
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat3: procedure expose m.
parse arg m, tt, pa1 paR
pa = tkrPatChk(m, pa1 paR)
if pa == '' then
return
if tt = pa1 then do
/* ok target reached, is there already a shorter path? */
do px=1 to m.m.pathRes.0
if wordsIsSub(pa, m.m.pathRes.px) then
return
end
/* remove all longer paths */
qx = 0
do px=1 to m.m.pathRes.0
if wordsIsSub(m.m.pathRes.px, pa) then
iterate
qx = qx+1
m.m.pathRes.qx = m.m.pathRes.px
end
/* add new path */
qx = qx+1
m.m.pathRes.qx = pa
m.m.pathRes.0 = qx
return
end
/* use direct connection if it exists */
if symbol('m.m.t2t.tt.pa1') == 'VAR' ,
| symbol('m.m.t2t.pa1.tt') == 'VAR' then do
call tkrPat2 m, tt, tt pa1 paR
return
end
tb1 = tkrTable(m, pa1)
/* try all connections from pa1 */
do rx=1 to words(m.tb1.rels)
r1 = word(m.tb1.rels, rx)
kL = tkrKey(m, m.r1.lef)
tL = m.kL.table
kR = tkrKey(m, m.r1.rig)
tR = m.kR.table
if m.tL.alias == pa1 then
a1 = m.tR.alias
else if m.tR.alias == pa1 then
a1 = m.tL.alias
else
call err 'relationship' tb1 'not connecting' pa1
if wordPos(a1, pa1 paR) > 0 then
iterate
call tkrPat2 m, tt, a1 pa1 paR
end
return
endProcedure tkrPat3
/*--- are there bad tables in path ? --------------------------------*/
tkrPatChk: procedure expose m.
parse arg m, pa
p2 = space(pa, 1)
do bx=1 to words(m.m.pathBad)
b1 = word(m.m.pathBad, bx)
if abbrev(b1, 1) then do /* 1 only at at begin or end */
wx = wordPos(substr(b1, 2), p2)
if wx > 1 & wx < words(p2) then
return ''
end
else if pos('|', b1) > 0 then do /* | must neighbour */
parse var b1 t1 '|' t2
wx = wordPos(t1, p2)
if wx > 1 & wx < words(p2) then
if word(p2, wx-1) \== t2 & word(p2, wx+1) \== t2 then
return ''
end
else if pos('-', b1) > 0 then do /* - no such sequence */
b2 = translate(b1, ' ', '-')
if pos(' 'b2' ', ' 'p2' ') > 0 then
return ''
b3 = '' /* - no reverse sequence */
do wx=1 to words(b2)
b3 = word(b2, wx) b3
end
if pos(' 'b3' ', ' 'p2' ') > 0 then
return ''
end
else
call err 'bad pathBad word' b1 'in' m.m.pathBad
end
return strip(p2)
endProcedure tkrPatChk
/*--- is short a subsequence of long?
e.g. wordIsSub( a b c d e f, b d f) --> true
wordIsSub( a b c d e f, b d c) --> false ----------------*/
wordsIsSub: procedure expose m.
parse arg long, short
sW = words(short)
if sW = 0 then
return 1
lW = words(long)
if sW > lW then
return 0
else if sW = lW then
return space(long, 1) == space(short, 1)
if word(long, lW) \== word(short, sW) then
return 0
lX = 1
do sX=2 to sW-1
lx = wordPos(word(short, sX), long, lX+1)
if lX <= 1 | sW-sX > lW-lX then
return 0
end
return 1
endProcedure wordsIsSub
/*--- format a value for sql ----------------------------------------*/
tkrValue: procedure expose m.
parse arg m, al, col, val
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
tt = tkrType(m, col)
if tt == 'c' then
return quote(val, "'")
if tt == 'n' then
if datatype(val, 'n') then
return val
else
call err 'not numeric' val 'for col' col
if tt == 'x' then
if verify(val, '0123456789abcdefABCDEF', 'n') < 1 then
return "x'"val"'"
else
call err 'not a hex value' val 'for col' col
call err 'unsupport tkrType' tt
endProcedure tkrValue
tkrType: procedure expose m.
parse arg m, col
if m == '' then
m = tkr
upper col
if wordPos(col, m.m.numeric) > 0 then
return 'n'
cNQ = substr(col, 1+pos('.', col))
if wordPos(cNQ, m.m.numeric) > 0 then
return 'n'
if wordPos(cNQ, m.m.hex) > 0 then
return 'x'
return 'c'
endProcedure tkrType
/*--- return sql col = val or col like val if there are mask chars --*/
tkrPred: procedure expose m.
parse arg m, al, col, va
if col == '-' | col == '' | va == '*' then
return ''
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
va = tkrValue(m, , col, va)
if abbrev(va, "'") then
if verify(va, '*%_', 'm') > 0 then
return 'and' col 'like' translate(va, '%', '*')
return 'and' col '=' va
endProcedure tkrPred
/*--- initialize tkr for db2Catalog ---------------------------------*/
tkrIniDb2Cat: procedure expose m.
parse arg m
call sqlCatIni
if m == '' then
m = tkr
if m.m.ini == 1 then
return
m.m.ini = 1
m.m.initialising = 1
m.m.allT = ''
y = 'sysIbm.sys'
mC = tkrIniT(m, 'c' y'Columns', 'tbCreator tbName name',
, 'tbCreator tbName colNo', , , '1')
mCo =tkrIniT(m, 'co' y'Copy',
, 'dbName tsName dsNum instance timestamp' ,
, 'co.dbName, co.tsName, co.timestamp desc',
,,'sqlCatCopy')
call tkrIniK m, mCo, '1plus', 'dbName tsName dsNum instance' ,
'timestamp icType start_Rba dsName pit_Rba'
mDb =tkrIniT(m, 'db' y'Database', 'name')
call tkrIniK m, mDb, 'id iu', 'DBID'
mI = tkrIniT(m, 'i' y'Indexes', 'creator name' ,
, 'tbCreator, tbName, creator, name', , , 'vl')
call tkrIniK m, mI, 't i', 'tbCreator tbName'
call tkrIniK m, mI, 'vl u', 'creator name tbCreator tbName'
call tkrIniK m, mI, 'db1 iu', 'dbName indexSpace'
mIK= tkrIniT(m, 'ik' ,
'sysibm.sysIndexes ik' ,
'left join sysibm.sysKeys ikK' ,
'on ikK.ixCreator = ik.creator' ,
'and ikK.ixName=ik.name' ,
'left join sysibm.sysColumns ikC' ,
'on ikC.tbCreator = ik.tbCreator' ,
'and ikC.tbName = ik.tbName' ,
'and ikC.colNo = ikK.colNo' ,
, 'creator name ikK.colSeq' ,
, 'ik.tbCreator, ik.tbName, ik.creator' ,
|| ', ik.name, ikK.colSeq', , 'sqlCatIxKeys','vl')
call tkrIniK m, mIK, 'vl u', 'creator name colName ',
'tbCreator tbName'
call tkrIniT m, 'ip' y'indexPart', 'ixCreator ixName partition' ,
, , , ,1
mPk =tkrIniT(m, 'pk' y'Package', 'location collid name conToken' ,
, 'location, collid, name, pcTimestamp desc',,,'vl')
call tkrIniK m, mPk, '1plus',
, 'location collid name contoken version type'
call tkrIniK m, mPk, 'vl',
, 'location collid name version'
mPkd=tkrIniT(m, 'pkd' y'PackDep',
, 'dLocation dCollid dName dConToken',,,,'vl')
call tkrIniK m, mPkd, 'b', 'bQualifier bName'
call tkrIniK m, mPkd, 'vl', 'dLocation dCollid dName' ,
'bQualifier bName'
mRc =tkrIniT(m, 'rc' 'oa1p.vqz005Recover', 'db ts pa',
,,,'sqlCatRec')
call tkrIniK m, mRc, '1plus', 'db ts pa fun recover',
'basPTT loadText unlTst unl punTst pun tb'
call tkrIniT m, 'ri' y'IndexSpaceStats' ,
, 'creator name partition' ,
, 'creator name instance partition' ,
, , 'sqlCatIxStats', 1
/* 'dbid isobid partition instance' , */
mRT= tkrIniT(m, 'rt' y'TableSpaceStats' ,
, 'dbId psId partition instance',
, 'dbName name instance partition' ,
, , 'sqlCatTSStats', ,
, 'dbName name: totalRows spaceF')
call tkrIniK m, mRT, '1plus', 'dbId psId partition instance' ,
'dbName name'
call tkrIniK m, mRT, 'nm u', 'dbName name partition instance'
mT = tkrIniT(m, 't' y'Tables', 'creator name',
, , "t.type not in ('A', 'V')", 'sqlCatTables', 1)
call tkrIniK m, mT, 'db i', 'dbName tsName'
call tkrIniK m, mT, '1plus', 'creator name dbName tsName'
mTg =tkrIniT(m, 'tg' y'Triggers', 'schema name seqno',
, 'tbOwner, tbName, schema, name',,, 1)
call tkrIniK m, mTg, 'tb', 'tbOwner tbName'
call tkrIniT m, 'tp' y'TablePart', 'dbName tsName partition'
mTs =tkrIniT(m, 'ts' y'TableSpace', 'dbName name')
call tkrIniK m, mTs, 'id', 'dbId psId'
call tkrIniT m, 'v' y'Tables', 'creator name',, "v.type = 'V'",,1
mVD =tkrIniT(m, 'vd' y'ViewDep', 'dCreator dName',,,,'vl')
call tkrIniK m, mVd, 'b', 'bCreator bName'
call tkrIniK m, mVd, 'vl', 'dCreator dName bCreator bName'
call tkrIniR m, 'c', 'v t'
call tkrIniR m, 'co', 'ts tp rt.nm rc'
p0sql = '(SelecT smallInt(0) p FroM sysibm.sysDummy1' ,
'union all select smallInt(32767)p FroM sysibm.sysDummy1)p0'
r1 = tkrRel(m, 'co-tp')
m.r1.rig.sql1 = '(co.dbName, co.tsName, co.dsNum)' ,
'in (select tp.dbName, tp.tsName' ,
', min(tp.partition, p0.p)' ,
'from sysibm.sysTablePart tp,' p0Sql 'where'
r2 = tkrRel(m, 'co-rt')
m.r2.rig.sql1 = '(co.dbName, co.tsName, co.dsNum, co.instance)' ,
'in (select rt.dbName, rt.name' ,
', min(rt.partition, p0.p), rt.instance' ,
'from sysibm.sysTablespaceStats rt,' p0Sql 'where'
call tkrIniR m, 'db', 'ts t.db tp rc rt co i.db1'
call tkrIniR m, 'i.t', 't'
call tkrIniR m, 'i', 'ik ip'
call tkrIniR m, 'pk', 'pkd'
call tkrIniR m, 'pkd.b', 'i', "pkd.bType in ('I')"
call tkrIniR m, 'pkd.b', 't v',
, "pkd.bType in ('A', 'G', 'M', 'S', 'T', 'V')"
call tkrIniR m, 'pkd.b', 'ts', "pkd.bType in ('P', 'R')"
call tkrIniR m, 'rc', 'tp'
call tkrIniR m, 'ri', 'i ip'
call tkrIniR m, 'rt', 'ts.id'
call tkrIniR m, 'rt.nm', 'tp rc'
call tkrIniR m, 'tg.tb', 'v t'
call tkrIniR m, 'ts', 't.db tp rc'
call tkrIniR m, 'vd.b', 't', "vd.bType in ('G', 'M', 'T', 'V')"
call tkrIniR m, 'vd', 'v', "vd.dType in ('V', 'M')"
m.m.pathBad = '1c 1co 1db 1tg pkd|pk vd|v pkd-i-t vkd-i-t'
m.m.numeric = 'PARTITION DBID INSTANCE PSID ISOBID DSNUM'
m.m.hex = 'CONTOKEN'
m.m.initialising = 0
return
endProcedure tkrIniDb2Cat
tkrIniT: procedure expose m.
parse arg m, ty tb, cols
mt = m'.t.'ty
if symbol('m.mt') == 'VAR' then
call err 'duplicate table' ty tb ord 'old' mt'->'m.mt
parse arg , , , m.mt.order, m.mt.cond,
, m.mt.editFun, m.mt.vlKey, m.mt.total
m.m.allT = m.m.allT ty
m.mt = 't?'
m.mt.alias = ty
m.mt.table = if(words(tb) == 1, tb ty, tb)
m.mt.keys = ''
m.mt.rels = ''
m.mt.pKey = tkrIniK(m, mt, '1 iu', cols)
return mt
endProcedure tkrIniT
tkrIniK: procedure expose m.
parse arg m, tb, nm oo, cols
if pos(':', cols) > 0 | pos(',', cols) > 0 then
call err 'deimplemented iiKey:' cols
mk = m'.k.'m.tb.alias'.'nm
if symbol('m.mk') == 'VAR' then
call err 'duplicate key' tb nm 'old' mk'->'m.mk
m.mk = 'k?'
m.mk.table = tb
m.mk.name = m.tb.alias'.'nm
m.mk.opt = oo
m.mk.colList = cols
m.tb.keys = strip(m.tb.keys mk)
return mk
endProcedure tkrIniK
tkrIniR: procedure expose m.
parse arg m, le, aRi, leCo, riCo
le = tkrKey(m, le)
lTb = m.le.table
do rx=1 to words(aRi)
ri = tkrKey(m, word(aRi, rx))
rTb = m.ri.table
ky = m'.r.'m.lTb.alias'-'m.rTb.alias
if symbol('m.ky') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.ky
m.ky = 'r'
m.ky.lef = le
m.ky.lef.sql1 = ''
m.ky.lef.cond = leCo || copies(' and', leCo \== '')
m.lTb.rels = m.lTb.rels ky
m.ky.rig = ri
m.ky.rig.cond = riCo || copies(' and', riCo \== '')
m.ky.rig.sql1 = ''
m.rTb.rels = m.rTb.rels ky
/* t2t contains forward relationship only | */
lr = m'.T2T.'m.lTb.alias'.'m.rTb.alias
if symbol('m.lr') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.lr
m.lr = ky
rl = m'.T2T.'m.rTb.alias'.'m.lTb.alias
if symbol('m.rl') == 'VAR' then
call err 'duplicate inverse relationShip' ky 'old' m.rl
end
return ky
endProcedure tkrIniR
tstTkrPath: procedure expose m.
/*
$=/tstTkrPath/
### start tst tstTkrPath ##########################################
17: c co db i ik ip pk pkd rc ri rt t tg tp ts v vd
c c -> c <- c .
c co -> c t ts co <- co ts t c
c db -> c t db <- db t c
c i -> c t i <- i t c
c ik -> c t i ik <- ik i t c
c ip -> c t i ip <- ip i t c
*** err: multiple (2) paths c<-pk: c t pkd pk <> c v pkd pk
*** err: multiple (2) paths pk<-c: pk pkd v c <> pk pkd t c
*** err: multiple (2) paths c<-pkd: c t pkd <> c v pkd
*** err: multiple (2) paths pkd<-c: pkd v c <> pkd t c
c rc -> c t ts rc <- rc ts t c
c ri -> c t i ri <- ri i t c
c rt -> c t ts rt <- rt ts t c
c t -> c t <- t c
*** err: multiple (2) paths c<-tg: c v tg <> c t tg
*** err: multiple (2) paths tg<-c: tg v c <> tg t c
c tp -> c t ts tp <- tp ts t c
c ts -> c t ts <- ts t c
c v -> c v <- v c
*** err: multiple (2) paths c<-vd: c t vd <> c v vd
*** err: multiple (2) paths vd<-c: vd v c <> vd t c
co co -> co <- co .
co db -> co db <- db co
co i -> co ts t i <- i t ts co
co ik -> co ts t i ik <- ik i t ts co
co ip -> co ts t i ip <- ip i t ts co
co pk -> co ts pkd pk <- pk pkd ts co
co pkd -> co ts pkd <- pkd ts co
co rc -> co rc <- rc co
co ri -> co ts t i ri <- ri i t ts co
co rt -> co rt <- rt co
co t -> co ts t <- t ts co
co tg -> co ts t tg <- tg t ts co
co tp -> co tp <- tp co
co ts -> co ts <- ts co
co v -> co ts t vd v <- v vd t ts co
co vd -> co ts t vd <- vd t ts co
db db -> db <- db .
db i -> db i <- i db
db ik -> db i ik <- ik i db
db ip -> db i ip <- ip i db
*** err: multiple (3) paths db<-pk: db i pkd pk <> db t pkd pk <> d+
b ts pkd pk
*** err: multiple (3) paths pk<-db: pk pkd ts db <> pk pkd t db <> +
pk pkd i db
*** err: multiple (3) paths db<-pkd: db i pkd <> db t pkd <> db ts +
pkd
*** err: multiple (3) paths pkd<-db: pkd ts db <> pkd t db <> pkd i+
. db
db rc -> db rc <- rc db
db ri -> db i ri <- ri i db
db rt -> db rt <- rt db
db t -> db t <- t db
db tg -> db t tg <- tg t db
db tp -> db tp <- tp db
db ts -> db ts <- ts db
db v -> db t vd v <- v vd t db
db vd -> db t vd <- vd t db
i i -> i <- i .
i ik -> i ik <- ik i
i ip -> i ip <- ip i
i pk -> i pkd pk <- pk pkd i
i pkd -> i pkd <- pkd i
i rc -> i t ts rc <- rc ts t i
i ri -> i ri <- ri i
i rt -> i t ts rt <- rt ts t i
i t -> i t <- t i
i tg -> i t tg <- tg t i
i tp -> i t ts tp <- tp ts t i
i ts -> i t ts <- ts t i
i v -> i t vd v <- v vd t i
i vd -> i t vd <- vd t i
ik ik -> ik <- ik .
ik ip -> ik i ip <- ip i ik
ik pk -> ik i pkd pk <- pk pkd i ik
ik pkd -> ik i pkd <- pkd i ik
ik rc -> ik i t ts rc <- rc ts t i ik
ik ri -> ik i ri <- ri i ik
ik rt -> ik i t ts rt <- rt ts t i ik
ik t -> ik i t <- t i ik
ik tg -> ik i t tg <- tg t i ik
ik tp -> ik i t ts tp <- tp ts t i ik
ik ts -> ik i t ts <- ts t i ik
ik v -> ik i t vd v <- v vd t i ik
ik vd -> ik i t vd <- vd t i ik
ip ip -> ip <- ip .
ip pk -> ip i pkd pk <- pk pkd i ip
ip pkd -> ip i pkd <- pkd i ip
ip rc -> ip i t ts rc <- rc ts t i ip
ip ri -> ip ri <- ri ip
ip rt -> ip i t ts rt <- rt ts t i ip
ip t -> ip i t <- t i ip
ip tg -> ip i t tg <- tg t i ip
ip tp -> ip i t ts tp <- tp ts t i ip
ip ts -> ip i t ts <- ts t i ip
ip v -> ip i t vd v <- v vd t i ip
ip vd -> ip i t vd <- vd t i ip
pk pk -> pk <- pk .
pk pkd -> pk pkd <- pkd pk
pk rc -> pk pkd ts rc <- rc ts pkd pk
pk ri -> pk pkd i ri <- ri i pkd pk
pk rt -> pk pkd ts rt <- rt ts pkd pk
pk t -> pk pkd t <- t pkd pk
*** err: multiple (2) paths pk<-tg: pk pkd v tg <> pk pkd t tg
*** err: multiple (2) paths tg<-pk: tg t pkd pk <> tg v pkd pk
pk tp -> pk pkd ts tp <- tp ts pkd pk
pk ts -> pk pkd ts <- ts pkd pk
pk v -> pk pkd v <- v pkd pk
*** err: multiple (2) paths pk<-vd: pk pkd t vd <> pk pkd v vd
*** err: multiple (2) paths vd<-pk: vd t pkd pk <> vd v pkd pk
pkd pkd -> pkd <- pkd .
pkd rc -> pkd ts rc <- rc ts pkd
pkd ri -> pkd i ri <- ri i pkd
pkd rt -> pkd ts rt <- rt ts pkd
pkd t -> pkd t <- t pkd
*** err: multiple (2) paths pkd<-tg: pkd v tg <> pkd t tg
*** err: multiple (2) paths tg<-pkd: tg t pkd <> tg v pkd
pkd tp -> pkd ts tp <- tp ts pkd
pkd ts -> pkd ts <- ts pkd
pkd v -> pkd v <- v pkd
*** err: multiple (2) paths pkd<-vd: pkd t vd <> pkd v vd
*** err: multiple (2) paths vd<-pkd: vd t pkd <> vd v pkd
rc rc -> rc <- rc .
rc ri -> rc ts t i ri <- ri i t ts rc
rc rt -> rc rt <- rt rc
rc t -> rc ts t <- t ts rc
rc tg -> rc ts t tg <- tg t ts rc
rc tp -> rc tp <- tp rc
rc ts -> rc ts <- ts rc
rc v -> rc ts t vd v <- v vd t ts rc
rc vd -> rc ts t vd <- vd t ts rc
ri ri -> ri <- ri .
ri rt -> ri i t ts rt <- rt ts t i ri
ri t -> ri i t <- t i ri
ri tg -> ri i t tg <- tg t i ri
ri tp -> ri i t ts tp <- tp ts t i ri
ri ts -> ri i t ts <- ts t i ri
ri v -> ri i t vd v <- v vd t i ri
ri vd -> ri i t vd <- vd t i ri
rt rt -> rt <- rt .
rt t -> rt ts t <- t ts rt
rt tg -> rt ts t tg <- tg t ts rt
rt tp -> rt tp <- tp rt
rt ts -> rt ts <- ts rt
rt v -> rt ts t vd v <- v vd t ts rt
rt vd -> rt ts t vd <- vd t ts rt
t t -> t <- t .
t tg -> t tg <- tg t
t tp -> t ts tp <- tp ts t
t ts -> t ts <- ts t
t v -> t vd v <- v vd t
t vd -> t vd <- vd t
tg tg -> tg <- tg .
tg tp -> tg t ts tp <- tp ts t tg
tg ts -> tg t ts <- ts t tg
tg v -> tg v <- v tg
*** err: multiple (2) paths tg<-vd: tg t vd <> tg v vd
*** err: multiple (2) paths vd<-tg: vd v tg <> vd t tg
tp tp -> tp <- tp .
tp ts -> tp ts <- ts tp
tp v -> tp ts t vd v <- v vd t ts tp
tp vd -> tp ts t vd <- vd t ts tp
ts ts -> ts <- ts .
ts v -> ts t vd v <- v vd t ts
ts vd -> ts t vd <- vd t ts
v v -> v <- v .
v vd -> v vd <- vd v
vd vd -> vd <- vd .
$/tstTkrPath/
*/
m = tkr
call tst t, 'tstTkrPath'
call tkrIniDb2Cat
call tstOut t, words(m.m.allT)':' m.m.allT
aa = m.m.allT
do ax = 1 to words(aa)
do ay=ax to words(aa)
oldErr = m.err.count
a = word(aa, ax)
b = word(aa, ay)
ab = tkrPath(m, a b)
ba = tkrPath(m, b a)
if oldErr \== m.err.count then
iterate
call tstOut t, a b '->' ab '<-' ba
wc = words(ab)
if wc <> words(ba) then
call tstOut t, 'inverse different len'
else do wx=1 to wc
if word(ab, wx) == word(ba, wc+1-wx) then
iterate
call tstOut t, 'path not inverse'
leave
end
end
end
call tstEnd t, 'tstTkrPath'
return 0
endProcedure tstTkrPath
/* copy tkr end **************************************************/
/* copy sqlCat begin ************************************************/
tstCatTb:
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call tstEnd t
return
endProcedure tstCatTb
sqlCatIni: procedure expose m.
if m.sqlCat_ini == 1 then
return
m.sqlCat_ini = 1
m.sqlCat_rbaF = '%-20H'
return
endProcedure sqlCatIni
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
call sqlFTabReset ft, 12, if(fTab, , 2000)
m.ft.opt = '-'left('c', \ fTab)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'RBA1' , m.sqlCat_rbaF
call FTabSet ft, 'RBA2' , m.sqlCat_rbaF
call FTabSet ft, 'START_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
sq = ''
if edFun \== '' then
interpret 'sq =' edFun'(ft, tb, wh, ord)'
if sq == '' then do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
end
call sqlQuery cx, sq
call sqlFTabOthers ft, cx
call sqlCatTbVl ft, tb
if fTab & m.tb.total <> '' then
call sqlCatTotalFtab cx, ft, m.tb.total
else
call sqlFTab ft, cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
ky = tkrKey(, tb) /* find the keys do show caxId */
kList = tkrKey(, tb) /* primary key first */
k.kList = m.kList.0 kList
do rx=1 to words(m.tb.rels) /* search relations */
r1 = word(m.tb.rels, rx)
kL = tkrKey(, m.r1.lef)
tL = m.kL.table
kR = tkrKey(, m.r1.rig)
tR = m.kR.table
if tb == tL then do
kM = kL
kO = kR
end
else if tb == tR then do
kM = kR
kO = kL
end
else
call err 'rel' r1 'not for' tb
if m.kO.0 > m.kM.0 then /* 1:N relationship */
iterate
if symbol('k.kM') \== 'VAR' then do
kList = kList kM
k.kM = m.kO.0 kO
end
else if word(k.kM, 1) < m.kO.0 then
k.kM = m.kO.0 kO
end
if sep == '' then
sep = sqlCatTbVLsep()
tt = sep
ff = sep
do wx=1 to words(kList)
ky = word(kList, wx)
parse var k.ky cnt kO
f2 = ''
t2 = ''
do kx=1 to word(k.ky, 1)
c1 = m.ky.kx.col
f1 = '%S'
if symbol('m.ft.set.c1') == 'VAR' then do
sx = m.ft.set.c1
fS = m.ft.set.sx.fmt
if translate(right(fS, 1)) = 'H' then
f1 = fS
end
t2 = t2'/'c1
f2 = f2'/@'c1 || f1
end
tO = m.kO.table
tt = tt m.tO.alias':'substr(t2, 2) sep
ff = ff m.tO.alias':'substr(f2, 2) sep
end
call fTabAdd ft, caxIdKeys, ff,
, 'caxIdKeys', tt
return
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAdd ft, substr(tt,length(sep)+1),
, substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql_conRzDB
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
lx = 1
plus = 0
stops = '/*-*/ (select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
if substr(sq, nx, 5) == '/*-*/' then do
sq = delStr(sq, nx, 5)
plus = plus + 1
cx = nx
iterate
end
call out int || substr(sq, lx, nx-lx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
lx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
/*--- ......-----------------------------*/
sqlCatTotalFtab: procedure expose m.
trace ?r
parse arg cx, ft, roll ':' sums
/* call sqlFtabComplete(ft, cx) */
i = in2Buf(sqlQuery2Rdr(cx))
call err 'please implement'
endProcedure sqlCatTotalFTab
sqlCatCopy: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = "select substr('' ||" al".instance || case" ,
"when" al".instance = 1 and s.clone = 'N' then ''" ,
"when s.clone = 'N' then 'only'" ,
"when s.instance =" al".instance then 'base'" ,
"else 'clone' end, 1, 6) insTxt" ,
", icType || case icType" ,
"when 'A' then '=alter'" ,
"when 'B' then '=rebuiIx'" ,
"when 'C' then '=create'" ,
"when 'D' then '=checkData'" ,
"when 'E' then '=recovToCu'" ,
"when 'F' then '=fulCopy'" ,
"when 'I' then '=incCopy'" ,
"when 'J' then '=comprDict'" ,
"when 'L' then '=sql'" ,
"when 'M' then '=modifyRec'" ,
"when 'P' then '=recovPIT'" ,
"when 'Q' then '=quiesce'" ,
"when 'R' then '=loaRpLog'" ,
"when 'S' then '=loaRpLoNo'" ,
"when 'T' then '=termUtil'" ,
"when 'V' then '=repairVer'" ,
"when 'W' then '=reorgLoNo'" ,
"when 'X' then '=reorgLog'" ,
"when 'Y' then '=loaRsLoNo'" ,
"when 'Z' then '=loaLog'" ,
"else '=???' end icTyTx" ,
',' al'.*' ,
'from' tkrTable( , tb, 't') 'join sysibm.sysTableSpace s' ,
'on' al'.dbName = s.dbName and' al'.tsName = s.name' ,
'where' wh 'order by' if(ord == '', m.tb.order, ord)
call fTabAdd ft, dbName , '%-8C', 'db'
call fTabAdd ft, tsName , '%-8C', 'ts'
call fTabAdd ft, dsNum , '%4i', 'part'
call fTabAdd ft, insTxt , '%6C', 'instan'
call fTabAdd ft, icTyTx , '%-11C','icType'
call fTabAdd ft, sType
call fTabAdd ft, oType
call fTabAdd ft, jobName
call fTabAdd ft, timestamp
call fTabAdd ft, dsName
return sq
endProcedure sqlCatCOPY
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call fTabAdd ft, CREATOR, '%-8C', 'creator'
call fTabAdd ft, NAME , '%-16C', 'index'
call fTabAdd ft, colSeq , '%5i', 'coSeq'
call fTabAdd ft, colName, '%-16C', 'column'
call fTabAdd ft, ordering
call fTabAdd ft, period
call fTabAdd ft, COLNO
call fTabAdd ft, COLTYPE
call fTabAdd ft, LENGTH
call fTabAdd ft, SCALE
call fTabAdd ft, NULLS
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
call fTabAdd ft, CREATOR, '%-8C', 'creator'
call fTabAdd ft, NAME , , 'index'
call fTabAdd ft, INSTANCE, '%1i', 'i'
call fTabAdd ft, PARTITION, , 'part'
return ''
endProcedure sqlCatIXStats
sqlCatRec: procedure expose m.
parse arg ft, tb, pWh, ord
wh = sqlWhereResolve(pWh)
al = m.tb.alias
vw = catRecView('cat')
if m.recView.unl then
sq = "select fun, recover, lok || ' ' || load loadText"
else
sq = "select case when left(recover, 2) = 'ok'",
"then 'r' else '?' end fun" ,
", '' stage, 'noXDocs' loadText" ,
", '' unlTst, '' unl, '' punTst, '' pun"
sq = sq", lPad(strip(basPa), 4) || basTy|| char(basTst) basPTT",
", ( select case when count(*) <> 1" ,
"then '|' || count(*) || 'tables'",
"else max(strip(creator) ||'.'|| name) end",
"/*-*/from sysibm.sysTables t" ,
"/*-*/where t.dbName =" al".db" ,
"and t.tsName="al".ts and type not in ('A', 'V')) tb",
"," al".*",
"from" vw al,
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call fTabAdd ft, db , '%-8C' , 'db'
call fTabAdd ft, ts , '%-8C' , 'ts'
call fTabAdd ft, pa , '%4i' , 'part'
call fTabAdd ft, insTxt , '%-5C' , 'insta'
call fTabAdd ft, fun , '%-2C' , 'fun'
call fTabAdd ft, stage , '%-2C' , 'sta'
call fTabAdd ft, recover , '%-7C' , '?recov?'
call fTabAdd ft, basPTT , '%-18C', 'part copytime'
call fTabAdd ft, loadText , '%-70C', '?load?'
call fTabAdd ft, unlTst , '%-19C', 'unloadTime'
call fTabAdd ft, unl , '%-44C', 'unloadDSN'
call fTabAdd ft, punTst , '%-19C', 'punchTime'
call fTabAdd ft, pun , '%-44C', 'punch'
call fTabAdd ft, 'TB' , '%-40C', 'table'
return sq
endProcedure sqlCatRec
sqlWhereResolve: procedure expose m.
parse arg wh
wh = strip(wh)
l1 = pos('(', wh)
l2 = pos('(', wh, l1+1)
l3 = pos('(', wh, l2+1)
r1 = pos(')', wh)
r2 = pos('FROM', translate(wh))
if r2 <= 0 then
if pos('SELECT', translate(wh)) < 1 then
return wh
else
call err 'select without from in where:' wh
if l1 <= 0 | l2 <= 0 | r1 <= 0 then
call err 'bad missing first 2 brackets where:' wh
if l1 <> 1 | r1 > l2 then
call err 'bad first bracket pair in where:' wh
if l2 >= r2 | (l3 <= r2 & l3 > 0) then
call err 'bad second bracket / from in where:' wh
if translate(strip(substr(wh, r1+1, l2-r1-1))) \== 'IN' then
call err 'in missing in where:' wh
li = translate(substr(wh, 2, r1-2), ' ', ',')
ci = substr(wh, l2+1, r2-l2-1)
if translate(word(ci, 1)) \== 'SELECT' then
call err 'missing select in where:' wh
ci = subWord(ci, 2)
cj = translate(ci, ' ', ',')
c0 = words(cj)
if c0 <> words(li) then
call err 'list 1&2 not equal len in where:' wh
do cx=1 to words(cj)
lA = word(cj, cx)
c.cx = translate(substr(lA, pos('.', lA) + 1))
l.cx = word(li, cx)
end
call sql2St substr(wh, l2+1, length(wh)-l2-1),
'group by' ci 'order by' ci, rr
c1 = c.1
c2 = c.2
r = ''
do rx=1 to m.rr.0
if rx = 1 then
ex = 0
else do
ry = rx - 1
do ex=1 to c0
cA = c.ex
if m.rr.rx.cA <> m.rr.ry.cA then
leave
end
ex = ex-1
if ex < c0 - 1 then
r = r copies(')', c0-ex)
end
do dx=ex+1 to c0
cA = c.dx
if dx = ex + 1 then
r = r 'or' left('(', dx < c0)
else
r = r 'and ('
r = r l.dx "= '"m.rr.rx.cA"'"
end
end
return substr(r, 4) copies(copies(')', c0), c0>1)
endProcedure sqlWhereResolve
catRecView: procedure expose m.
parse arg m
m.recView.unl = wordPos(m.m.dbSy, 'DBOF DVBP') > 0
if \ m.recView.unl then
return 'oa1p.vqz005Recover'
call sql2St "select punTst tst, err" ,
", case when punTst < current timestamp - 1 hour" ,
"then 1 else 0 end att" ,
"from oa1p.tQZ005TecSvUnload" ,
"where stage = '-r'", recView
call out ' '
t = 'Recovery Unloads aus oa1p.tQZ005TecSvUnload'
if m.m.dbSy = 'DVBP' then
call out ' ELAR XB' t
else
call out ' EOS und eRet (XC, XR)' t
t = 'refresh='m.recView.1.tst 'err='m.recView.1.err
if m.recView.0 < 1 then
call out ' Achtung: ist leer'
else if m.recView.0 > 1 then
call out ' Achtung: zuviele ('m.recView.0') -r rows'
else if m.recView.1.att = 1 then
call out ' Achtung: älter 1h:' t
else
call out ' ' t
call out ' cx -ru ... für refresh unload'
call out ' '
return 'oa1p.vqz005RecovLoad'
endProcedure catRecView
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
',' sqlLrsn2tst('rba1') 'rba1Tst' ,
',' sqlLrsn2tst('rba2') 'rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call fTabAdd ft, creator , '%-8C' , 'creator'
call fTabAdd ft, NAME , '%-24C', 'table'
call fTabAdd ft, type
call fTabAdd ft, dbNAME , '%-8C' , 'db'
call fTabAdd ft, tsNAME , '%-8C' , 'ts'
call fTabAdd ft, tsType
call fTabAdd ft, partitions, , 'parts'
call fTabAdd ft, pgSize
call fTabAdd ft, dsSize
call fTabSet ft, rba1 , m.sqlCat_rbaF
call fTabSet ft, rba1Tst , , 'rba1Timestamp:GMT'
call fTabSet ft, rba2 , m.sqlCat_rbaF
call fTabSet ft, rba2Tst , , 'rba2Timestamp:GMT'
return sq
endProcedure sqlCatTables
sqllrsn2tst: procedure expose m.
parse arg f /* sql fails in v10 without concat | */
return "timestamp(case when length("f") = 6 then" f "|| x'0000'" ,
"when substr("f", 1, 4) = x'00000000' then" ,
"substr("f" || X'000000000000', 5, 8)" ,
"else substr("f" || X'00000000', 2, 8) end)"
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
call fTabAdd ft, DBNAME , '%-8C', 'db'
call fTabAdd ft, NAME , '%-8C', 'ts'
call fTabAdd ft, INSTANCE , '%1i', 'i'
call fTabAdd ft, PARTITION , , 'part'
call fTabAdd ft, NACTIVE , , 'nActive'
call fTabAdd ft, NPAGES , , 'nPages'
call fTabAdd ft, SPACE , , 'spaceKB'
call fTabAdd ft, TOTALROWS , , 'totRows'
call fTabAdd ft, DATASIZE , , 'dataSz'
call fTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call fTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call fTabAdd ft, REORGINSERTS , , 'inserts'
call fTabAdd ft, REORGDELETES , , 'deletes'
call fTabAdd ft, REORGUPDATES , , 'updates'
call fTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call fTabAdd ft, REORGDISORGLOB , , 'disorgL'
call fTabAdd ft, REORGMASSDELETE , , 'massDel'
call fTabAdd ft, REORGNEARINDREF , , 'nearInd'
call fTabAdd ft, REORGFARINDREF , , 'farInd'
call fTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call fTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call fTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call fTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call fTabAdd ft, STATSINSERTS , , 'inserts'
call fTabAdd ft, STATSDELETES , , 'deletes'
call fTabAdd ft, STATSUPDATES , , 'updates'
call fTabAdd ft, STATSMASSDELETE , , 'massDel'
call fTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call fTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call fTabAdd ft, COPYUPDATELRSN , m.sqlCat_rbaF, 'updateLRSN'
call fTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call fTabAdd ft, COPYCHANGES , , 'changes'
return ''
endProcedure sqlCatTSStats
/* copy sqlCat end ************************************************/
/* rexx ****************************************************************
wsh: walter's rexx shell version 6.1
interfaces: 29. 7.16
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
wsh s: sql processor
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
==> previous version under wsh4 <==
--- history ------------------------------------------------------------
29. 7.16 log for s_users to dsn.wshLog else to tss.ska.db2.wshlog
allow dd out sysout, assume reclen 32755 / spell out truncation error
*********/ /*** end of help ********************************************
13. 7.16 sqlFTabAdd und fTabAddRCT ersetzt druch ftabAdd
6.16 neues sql, sqlWsh, wshMain etc., test to end
23.12.15 dsnList, dsnCopy und dsnDel
16. 1.15 f: get/put read/write in/out Object/Strings transparent weiter
17.11.14 f: iirz2p ==> plex Buchstaben
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
**********************************************************************/
/*--- main code wsh -------------------------------------------------*/
call errReset 'hI'
numeric digits 12 /* full int precision, but not bigInt | */
m.myLib = 'A540769.WK.REXX'
m.myWsh = 'WST'
m.myVers = 'v61 29.07.16'
call wshLog
parse arg spec
isEdit = 0
editDsn = ''
m.wsh.outLen = 157
if spec = '' & m.err_ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
editDsn = dsnSetMbr(d, m)
if abbrev(editDsn, 'A540769.WK.REXX(WS') ,
& length(dsnGetMbr(editDsn)) <= 4 then do
isEdit = 0
if spec = '' then
spec = 't'
end
end
end
spec = strip(spec)
if spec = '?' then
return help()
inp = ''
out = ''
call utIni
if m.err_os == 'TSO' then do
if isEdit then do
call pipeIni
parse value wshEditBegin(wsh) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
call pipeIni
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if useOut = 0 then do
out = file('dd(out)')
m.wsh.outLen = sysLrecL - 4 * abbrev(sysRecFM, 'V')
end
else if (useOut = 16 & sysReason = 2) then do
end /* dd out not allocated, use say to sysTsPrt */
else if (useOut = 16 & sysReason = 3) then do
out = file('dd(out)') /* hope for sysout */
m.wsh.outLen = 32755 /* assume large maxRecL */
end
else if \ (useOut = 16 & sysReason = 2) then do
call err 'listDsi dd out cc='useOut',
, sysReason='sysReason 'm2='sysMsgLvl2', m1='sysMsgLvl1
end
end
end
else if m.err_os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err_os
m.wsh.pipeOut = out \== ''
if m.wsh.pipeOut then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
do m.wsh.pipeOut * 2
drop out q
q = m.j.out
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'pipe.0='m.pipe.0 'at end'
if isEdit then
call wshEditEnd wsh
exit m.wsh.exitCC
/*--- call hooks and/or compile wsh
finally execute any generated code ----------------------------*/
wshRun: procedure expose m.
parse arg m, spec, inp
m.m.info = 'compile'
r = wshCompRun(m, spec, inp)
m.m.info = 'run'
if r \== '' then
call oRun r
return
endProcedure wshRun
/*--- call hooks and/or compile wsh
return generated code as ORunner or ''-------------------------*/
wshCompRun: procedure expose m.
parse arg m, spec, inp
if m == '' then do
if symbol('m.wsh_new') \== 'VAR' then
m.wsh_new = 1
else
m.wsh_new = m.wsh_new + 1
m = 'wsh_new'm.wsh_new
end
m.m.in = inp
m.m.comp = ''
m.m.kind = '@'
m.m.out = ''
m.m.end = 0
run = ''
rest = strip(spec)
if abbrev(rest, '$#') then
rest = strip(substr(rest, 3))
do until m.m.comp \== '' | rest = ''
parse var rest s2 '$#' r2
run = run wshHook(m, strip(s2), rest)
rest = r2
end
if m.m.comp \== '' then do
c = m.m.comp
s = m.c.scan
do while \ (m.m.end | scanEnd(s))
if \ scanLit(s, '$#') then
return scanErr(s, 'wsh' compKindDesc(m.m.kind) ,
"expected: compile stopped before end of input")
call scanChar s
sp2 = m.s.tok
run = run wshHook(m, sp2, sp2)
end
call compEnd c
end
run = space(run, 1)
if words(run) <= 1 then
return run
else
return oRunner('call oRun' repAll(run, ' ', '; call oRun '))
endProcedure wshCompRun
/*--- compile wsh until eof or unknown syntax -----------------------*/
wshHook: procedure expose m.
parse arg m, spec, specAll
parse var spec sp1 spR
if verifId(sp1) > 0 | sp1 == '' then
return wshCompOne(m, specAll)
if wordPos(sp1, 'out end version') <= 0 then do
cd = "return wshHook_"sp1"(m, '"strip(spR)"')"
/* say 'interpreting hook' cd */
interpret cd
end
c = m.m.comp
s = m.c.scan
if c == '' then
call err 'wshHook before compiler created:' spec
else if sp1 == 'out' then do
m.m.out = scanPos(s)
m.m.end = 1
end
else if sp1 == 'end' then
call scanNlUntil s, '$#out'
else if m.s.tok == 'version' then
call scanErr s, 'implement version'
return ''
endProcedure wshHook
/*--- initialize compiler if necessary and compile one unit ---------*/
wshCompOne: procedure expose m.
parse arg m, spec
spec = strip(spec, 'l')
if m.m.comp == '' then
call wshIni
if pos(left(spec, 1), m.comp_chKind'*') > 0 then
parse var spec m.m.kind 2 spec
if m.m.comp == '' then do
c = comp(m.m.in)
m.m.comp = c
call compBegin c, spec
end
else do
c = m.m.comp
call scanBack m.c.scan, spec
end
return compileOne(c, m.m.kind)
endProcedure wshCompOne
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if abbrev(userid(), 'S') then
lNm = 'dsn.wshlog' /* da duerfen S-Pids */
else
lNm = 'tss.ska.db2.wshlog' /* da duerfen alle User */
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lN2 '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = m.myLib'('s3')' word(m.myVers, 1) sysvar(sysnode) ,
'j='mvsvar('symdef', 'jobname') ,
'u='userid() date('s') time()
if msg <> '' then
o.2 = left(msg, 80)
ox = 1 + (msg <> '')
if st <> '' then do sx=1 to m.st.0
ox = ox+1
o.ox = left(m.st.sx, 80)
end
call writedd log, o., ox
call tsoClose log
call tsoFree log
return
endProcedure wshLog
/*--- hook for out format -------------------------------------------*/
wshHook_outFmt: procedure expose m.
parse arg m, rest
if m.pipe.0 \== 4 then
call err 'wshHook_outFmt but pipe.0='m.pipe.0
call pipe '-'
if rest = 'e' then
call pipe '+F', csvV2Frdr(csvExtRdr(m.j.out), m.m.outLen-4)
else
call err 'wshHook_outFmt unsupported fmt='rest
return ''
endProcedure wshHook_outFmt
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg m, inp
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call wshIni
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun wshCompRun( ,mode, jBuf(inp))
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- find input ramge, destination and set errHandler
and return input and output files ----------------------------*/
wshEditBegin: procedure expose m.
parse arg m
pc = adrEdit("process dest range Q", 0 4 8 12 16)
call adrEdit "(zLa) = lineNum .zl"
if pc = 16 then
call err 'bad range must be q'
rFi = 1
rLa = zLa
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
dst = ''
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
end
call jReset oMutate(m'.EDITIN', m.class_JBuf)
b = m'.EDITIN.BUF'
bx = 0
do lx=rFi to rLa
call adrEdit "(li) = line" lx
if abbrev(li, '$#end') then do lx=lx+1 to rLa ,
until abbrev(li, '$#out')
end
if abbrev(li, '$#out') then do
if dst = '' then
dst = lx - 1
leave
end
bx = bx + 1
m.b.bx = li
end
m.b.0 = bx
m.m.editRFirst = rFi
m.m.editREnd = rFi + bx
m.m.editDst = dst
if dst == '' then do
m.m.editOut = ''
end
else do
call adrEdit '(recl) = LRECL'
m.m.outLen = recL
m.m.editOut = jOpen(jReset(oMutate(m'.EDITOUTF',
, m.class_JBuf)), '>')
call jWrite m.m.editOut, left('$#out', 50) date('s') time()
end
call errReset 'hso', "return wshEditErrH('"m"', ggTxt)"
return m'.EDITIN' m.m.editOut
endProcedure wshEditBegin
/*--- copy output to editArea ---------------------------------------*/
wshEditEnd: procedure expose m.
parse arg m
call errReset 'h'
if m.m.editOut == '' then
return 0
call jClose m.m.editOut
call wshEditInsertSt wshEditInsertCmd(m.m.editDst, 'wshDs'),
, , m.m.editOut'.BUF'
call wshEditLocate m.m.editDst, 1
return 1
endProcedure wshEditEnd
/*--- scroll such that given line is nicely visible -----------------*/
wshEditLocate: procedure
parse arg ln, top
call adrEdit 'down max'
call adrEdit '(fi, la) = display_lines'
if top then
lx = ln - 7
else
lx = ln - la + fi + 7
if fi <> 1 & lx < fi then
call adrEdit 'locate' max(1, lx)
return
endProcedure wshEditLocate
/*--- error handle for wsh in edit mode
mark location of wsh syntax error -----------------------------*/
wshEditErrH: procedure expose m.
parse arg m, ggTxt
call errReset 'hso'
ee = errSay(ggTxt'\nin wsh phase' m.m.info)
isScan = 0
if wordPos("pos", m.ee.3) > 0 ,
& pos(" in line ", m.ee.3) > 0 then do
parse var m.ee.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ee.3 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
call wshEditEnd m
if m.m.Info=='compile' & isScan then do
lx = m.m.editRFirst + lin - 1
cmd = wshEditInsertCmd(lx, 'wshEr')
if pos \= '' then
call wshEditInsert cmd, 'msgline', right('*',pos)
call wshEditInsertSt cmd, 'msgline', ee
call wshEditLocate lx, 0
end
call errCleanup
exit 8
exit
endSubroutine wshEditErrH
/*--- return editor insert cmd for after line afX -------------------*/
wshEditInsertCmd: procedure
parse arg afX, lb
call adrEdit "(zLa) = lineNum .zl"
if afX >= 1 & afX < zLa then do
call adrEdit 'label' (afX+1) '= .'lb
return 'line_before .'lb '='
end
else if afX = zLa then
return 'line_after .zl ='
else
call err 'dst='afX 'but .zl='zLa
endProcedure wshEditInsertCmd
/*--- insert lines, format msgLines ---------------------------------*/
wshEditInsert: procedure
parse arg cmd, type
do ax=3 to arg()
li = strip(arg(ax), 't')
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return
endProcedure wshEditInsert
/*--- insert all lines of stem st -----------------------------------*/
wshEditInsertSt: procedure expose m.
parse arg cmd, type, st
if cmd == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
do ax=1 to m.st.0
call wshEditInsert cmd, type, m.st.ax
end
return
endProcedure wshEditInsertSt
/*** end wsh, begin all copies ***************************************/
/*** abub compatibility **********************************************/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure
/*** end abub compatibility ******************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlSini
call fTabIni
call csmIni
return
endProcedure wshIni
/* copy wshCopy end ************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy sort begin ***************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ***************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
**********************************************************************/
/***** initialisation ************************************************/
/*--- module initialisation -----------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = ' 'x2c('09')
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp.idChars = m.ut_alfNum'@_'
m.comp.wCatC = 'compile'
m.comp.wCatS = 'do withNew with for forWith ct proc arg table'
m.comp_astOps = m.comp_chOp'!)&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ---------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile the source with kind ki
and return oRunner with the code -------------------------*/
compile: procedure expose m.
parse arg m, ki
call compBegin m
s = m.m.scan
res = compileOne(m, ki)
if 0 then
call compAstSay res, 0
if \ scanEnd(s) & m.m.out == '' then
return scanErr(s, 'wsh' compKindDesc(ki) "expected: compile",
"stopped before end of input")
call compEnd m
return res
endProcedure compile
compBegin: procedure expose m.
parse arg m, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m
if m.m.cmpRdr \== '' then
call scanReadClose m.m.scan
return m
endProcedure compEnd
/*--- compile one unit and return oRunner or '' -------------------*/
compileOne: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
if ki == '*' | m.m.end \== '' then do
call scanNlUntil s, '$#out'
return ''
end
a = compUnit(m, ki, '$#')
if a == '' then
return ''
cd = compAst2Rx(m, '!', a)
if 0 then
say cd
return oRunner(cd)
endProcedure compileOne
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '¢-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code -----------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/¢') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
/* if pos(right(op, 1), m.comp_chKiNO) > 0 then
op = left(op, length(op)-1) ?????? */
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause -----------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code --------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
kiTxt = translate(ki, ';-', '@=')
s = m.m.scan
res = compAst(m, '¢')
withNew = ''
nlLe = 0 /* sophisticated logic using left and right NLs*/
tb = ''
do forever
if tb \== '' then do
fx=0
fy = m.tb.0
fL = m.tb.fy
aa = ''
do forever
call compSpComment m
px = m.s.pos
do until px < m.ff.end | fx >= m.tb.0
fx = fx + 1
ff = m.tb.fx
end
if fx > m.tb.0 then do
if compExpr(m, 's', m.fL.colKind) == '' then
leave
call err 'fallout table'
end
e1 = compExpr(m, 's', m.ff.colKind, m.ff.end)
if e1 == '' then
leave
else if fx > m.tb.0 then
call err 'fallout table'
if m.ff.colOps \== '' then
e1 = compAstAddOp(m, e1, m.ff.colOps)
if aa == '' then
aa = compAst(m, '¢')
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
end
if aa \== '' then
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.tb.class"')")),
, aa, compAst(m, '*', '!.'))
/* px = m.s.pos
e1 = compExpr(m, 'w', '=')
if e1 \== '' then do
aa = compAst(m, '¢')
fx = 0
do until e1 == ''
do fx=fx+1 to m.tb.0 until px < m.ff.end
ff = m.tb.fx
end
if fx > m.tb.0 then
call scanErr s, 'right of all table fields'
if m.s.pos <= m.ff.pos then
call scanErr s, 'before table field' m.ff.name
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
end
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, 'o', "oNew('"m.tb.class"')"),
, aa, compAst(m, '*', '$.'))
end
*/ nlRi = scanNL(s)
end
else if ki == ':' then do
call compSpNlComment m, '*'
nlRi = 0
end
else if ki == '@' then do
call compSpNlComment m
one = compExpr(m, 's', ki)
if one == '' then
nlRi = 0
else if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
else do
do forever /* scan all continued rexx lines */
nlRi = 1
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
call mAdd res, one
end
end
else if ki == '%' | ki == '^' then do
do cc=0 while compSpNlComment(m)
end
one = compExpr(m, 's', ki)
nlRi = one \== ''
if nlRi then
call mAdd res, one
end
else do
do cc=0 while compComment(m)
end
one = compExpr(m, 'd', ki)
nlRi = scanNL(s)
if one == '' then do
if nlLe & nlRi & cc < 1 then
call mAdd res,compAst(m, kiTxt, ,compAst(m,'='))
end
else if m.one.containsD | (nlLe & nlRi,
& \ (cc > 0 | m.one.containsC)) then do
call mAdd res, one
end
else do
call mFree one
end
end
nlLe = nlRi
if \ nlRi then do
one = compStmt(m, ki)
if one \== '' then do
call mAdd res, one
end
else if scanLit(s, 'table', '$table') then do
tb = compTable(m, ki)
end
else do
if withNew \== '' then do
r = compAst(m, 'F', 'withNew', '', res,
, compAst(m, '*', '!.'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
res = withNew
call mAdd res, r
m.m.comp_assVars = assVars
end
if scanLit(s, 'withNew', '$withNew') then do
withNew = res
assVars = m.m.comp_assVars
m.m.comp_assVars = ''
res = compAst(m, '¢')
end
else
return compAstFree0(res)
end
end
end
endProcedure compExprStmts
/*--- compile a single statement ------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compStmt(m, ki),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compStmt(m, ki), 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compStmt(m, ki), "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compStmt(m, ki), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '¢' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit -----------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '¢' then
stopper = m.comp_chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/*--- compile table body and return table ---------------------------*/
compTable: procedure expose m.
parse arg m, ki
s = m.m.scan
call compSpComment m
if scanNl(s) then
call compSpComment m
res = compAst(m, 'T', 'c')
flds = ''
pB = 1
do forever
opKi = compOpKind(m)
if compName(m, 'v') \== 'v' then
if opKi == '' then
leave
else
call scanErr s, 'table col expected after' opKi
f1 = compAst(m, 'T')
m.f1.pos = pB
if opKi == '' then
opKi = translate(ki, '=', ':')
m.f1.colKind = right(opKi, 1)
m.f1.colOps = left(opKi, length(opKi)-1)
m.f1.name = m.s.tok
if pos(left(opKi, 1), '-=#') > 0 then
flds = flds', f' m.s.tok 'v'
else
flds = flds', f' m.s.tok 'r'
call compSpComment m
pB = m.s.pos
m.f1.end = pB
m.f1.text = 'f blabla' m.f1.name m.f1.pos pB opKi
call mAdd res, f1
if scanLit(s, ',') then
call compSpComment m
end /* ?????????????????????????
do while compName(m, 'v') == 'v'
f1 = compAst(m, 'T')
m.f1.end = m.s.pos
m.f1.pos = m.s.pos - length(m.s.tok)
m.f1.name = m.s.tok
m.f1.text = 'f' m.f1.name m.f1.pos m.f1.end
call mAdd res, f1
flds = flds', f' m.s.tok 'v'
call compSpComment m
end ???????? */
if \ scanNl(s) then
call scanErr s, 'name or nl after table expected'
if m.res.0 < 1 then
call scanErr s, 'no names in table'
m.f1.end = ''
m.res.class = classNew('n* CompTable u' substr(flds, 3))
m.res.text = 'c' cl
return res
endProcedure compTable
/**** lexicals *******************************************************/
/*--- skip a comment. return 0 if there is none ---------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments --------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ---------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp.wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp.wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '¢' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ****************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
¢ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ! execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
**********************************************************************/
/*--- create a new AST ----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ---------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST -------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg -------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')!') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '!') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '!' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, '!', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@!)') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,'!', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, '!', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, '!', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, '!', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, '!', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'wshCompRun( ,'args ',in2Buf())')
end
return compAstErr(a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a)
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '¢' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
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
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' ''"'
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
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
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanOpen
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procecure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
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
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
m.m.src = m.r
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf) -------------------*/
after rdr is positioned to line before -------------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 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 jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead 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 scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- 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-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0', 'dlt m.m.cutLen'
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
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
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 comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
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 scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'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 scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'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 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' 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, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
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 scanSpace 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, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(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, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
interpret objMet(m, 'scanSqlIn2Scan')
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end ************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
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 m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'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 = scanSpace(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 \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
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.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets -------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut ----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end *************************************************/
/* copy pipe begin *****************************************************
**********************************************************************/
pipeIni: procedure expose m.
if m.pipe_ini == 1 then
return
m.pipe_ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end *****************************************************/
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
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.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
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
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
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.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a ----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy mat begin ****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end ****************************************************/
/* copy db2Util begin ************************************************/
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' m.in
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call out ' SORTDEVT DISK '
do in()
li = m.in
if pos('CHAR(', li) > 0 then
call out strip(li, 't') 'TRUNCATE'
else if word(li, 1) word(li, 3) == 'PART INDDN' then do
call out li,
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
call out ' DISCARDDN TDISC '
end
else
call out li
end
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy sqlDiv begin *************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa ------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), maxCh, maxBlo, maxDe)
/*--- default formats per datatype ----------------------------------*/
sqlFTabOpts: procedure expose m.
parse arg ff, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff --------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
/*--- complete / override column info from sqlCa --------------------*/
sqlFTabComplete: procedure expose m.
parse arg m, cx, aOth, aFmt
if aOth then
call sqlFTabOthers m, cx
f2x = classMet(sqlFetchClass(cx), 'f2x')
do tx=1 to m.m.0
c1 = m.m.tx.col
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
parse var m.m.set.sx c1 aDone
m.m.tx.done = aDone \== 0
m.m.tx.fmt = m.m.set.sx.fmt
m.m.tx.labelSh = m.m.set.sx.labelSh
end
if symbol('m.f2x.c1') \== 'VAR' then
iterate
kx = m.f2x.c1
if m.m.tx.labelLo = '' then
m.m.tx.labelLo = m.sql.cx.d.kx.sqlName
if m.m.tx.labelSh = '' then
m.m.tx.labelSh = m.sql.cx.d.kx.sqlName
if m.m.tx.fmt <> '' | \ aFmt then
iterate
/* use format for datatype */
ty = m.sql.cx.d.kx.sqlType
ty = ty - ty // 2 /* odd = with null */
le = m.sql.cx.d.kx.sqlLen
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
pr = m.sql.cx.d.kx.sqlLen.sqlPrecision
sc = m.sql.cx.d.kx.sqlLen.sqlScale
if sc < 1 then
f1 = '%' || (pr + 1) || 'i'
else
f1 = '%' || (pr + 2) || '.'sc'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
m.m.tx.fmt = f1
end
return m
endProcedure sqlFTabComplete
/*--- add all cols of sqlCA to fTab,
that are not yet (witho aDone=0) ----------------------*/
sqlFTabOthers: procedure expose m.
parse arg m, cx
do cy=1 to m.m.0
if m.m.cy.done then do
nm = m.m.cy.col
done.nm = 1
end
end
ff = m.sql.cx.fetchFlds
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
if done.c1 \== 1 then
call ftabAdd m, c1
end
return m
endProcedure sqlFTabOthers
/*--- fetch all rows from cursor cx, tabulate and close crs ---------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('s', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if pos('a', m.m.opt) > 0 | pos('o', m.m.opt) > 0 then
return fTab(m, sqlQuery2Rdr(cx))
/* fTab would also work in other cases,
however, we do it without sqlQuery2Rdr */
dst = 'SQL_fTab_dst'
if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
do rx=1 while sqlFetch(cx, dst)
call out left('--- row' rx '', 80, '-')
call fTabCol m, dst
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
end
else do
call fTabBegin m
do rx=1 while sqlFetch(cx, dst)
call out f(m.m.fmt, dst)
end
call fTabEnd m
end
call sqlClose cx
return m
endProcedure sqlFTab
/*--- create insert statment into table tb
for object m in spufi (72chars) format ---------------------*/
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFldD(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState --------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/* say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ---------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ---------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end *************************************************/
/* copy db2Cat begin *************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'",,,, 'r')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq sq, colName col, ordering ord" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end *************************************************/
/* copy sqlWsh begin **************************************************
remote SQL using csmExWsh ************************************/
sqlWshIni: procedure expose m.
if m.sqlWsh_ini == 1 then
return
m.sqlWsh_ini = 1
call sqlSIni
call csmIni
call classNew 'n SqlWshRdr u CsmExWsh', 'm',
, "jReset call jReset0 m; m.m.rdr = jBuf()" ,
"; m.m.rzDb=arg; m.m.src = arg2;m.m.type= arg(3)" ,
, "jOpen call sqlWshRdrOpen m, opt"
call classNew 'n SqlWshConn u', 'm',
, "sqlRdr return oNew(m.class_sqlWshRdr, m.sql_conRzDb" ,
", src, type)" ,
, "sqlsOut return sqlWshOut(rdr,m.sql_conRzDB,retOk,m.ft.opt)"
return
endProcedure sqlWshIni
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshRdrOpen: procedure expose m.
parse arg m, oOpt
r = m.m.rdr
m.r.buf.0 = 1
m.r.buf.1 = sqlRdrOpenSrc(m, oOpt)
parse var m.m.RzDb m.m.rz '/' dbSys
m.m.wOpt = 'e sqlRdr' dbSys
call csmExWshOpen m, oOpt
d = m.m.deleg
em = ''
do while jRead(d)
if objClass(m.d) \== m.class_S then do
m.d.readIx = m.d.readIx - 1
leave
end
em = em'\n'm.d
end
if em == '' then
return m
call jClose m.m.deleg
return err('sqlWshRdr got' substr(em, 3))
endProcedure sqlWshRdrOpen
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshOut: procedure expose m.
parse arg rdr, rzDb, retOk, oo
parse value dsnCsmSys(rzDb) with rz '/' dbSys
if oo = 'o' then
spec = 'e sqlsOut' dbSys 'o'
else
spec = 'v' || (m.wsh.outLen+4) 'sqlsOut' dbSys oo
call csmExWsh rz, rdr, spec
return 1
endProcedure sqlWshOut
/* copy sqlWsh end *************************************************/
/* copy sqlS begin **************************************************
sqlStmts **********************************************/
sqlSIni: procedure expose m.
call sqlOIni
call scanWinIni
return
endProcedure sqlSIni
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt, fOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk,
, word(fOpt 'a', 1))
endProcedure sqlStmts
/*--- output sql as table -------------------------------------------*/
sql2tab: procedure expose m.
parse arg src, retOk, ft
cx = m.sql_defCurs
if ft == '' then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c' , '-'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c', '-'ft))
call sqlQuery cx, in2str(src, ' '), retOk
call sqlFTab ft, cx
return
endProcedure sql2tab
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, ft
if ft = '' then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , 'a'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , ft))
interpret classMet(m.sql_ConCla, 'sqlsOut')
sqlsOutSql: procedure expose m.
parse arg rdr, retOk, ft
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = m.sql_defCurs
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' | m.sql.cx.fun == 'CALL' then
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
if m.sql.cx.resultSet == '' then
iterate
do until \ sqlNextResultSet(cx) | m.sql_errRet
call sqlFTab fTabResetCols(ft), cx
call out sqlMsgLine(m.sql.cx.fetchCount 'rows fetched', , m.r)
end
end
call jClose r
if m.sql_errRet then do
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
return \ m.sql_errRet
endProcedure sqlsOutSql
/*--- sql hook ------------------------------------------------------
hook paramter db? windowSpec?
db: dbSys, rz/dbSysAbkürzung, 1 oder 2 chars
windowSpec: 0 = variable len, 123 = window123
default spufi = window72 ---------------------*/
wshHook_S: procedure expose m.
parse arg m, spec
parse var spec ki 2 rest
call sqlWshIni
call errSetSayOut 'so'
if ki == '/' then do
inp = m.m.in
end
else do
call compIni
if pos(ki, m.comp_chKind) <= 0 then do
ki = '='
rest = spec
end
inp = wshCompOne(m, ki)
end
rest = strip(rest)
if words(rest)==1 & (datatype(rest, 'n') | pos('@',rest)>0) then
dbSy = ''
else
parse var rest dbSy rest
d2 = ii2rzDb(dbSy, 1)
call sqlConnect d2, left('w', \ abbrev(d2, '*/'))
m.m.info = 'runSQL'
if \ sqlStmts(inp, 'rb ret', rest) then do
m.m.end = 1
m.m.exitCC = 8
end
call sqlDisConnect
return ''
endProcedure wshHook_s
/*--- wshHook for sqlRdr read from dd wsh --------------------------*/
wshHook_sqlRdr: procedure expose m.
parse arg m, dbSys
call errSetSayOut 'so'
call sqlSIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if \ m.sql_errRet then
r = sqlRdr(m.m.in)
if \ m.sql_errRet then
call jOpen r, '<'
if \ m.sql_errRet then do
call pipeWriteAll r
call jClose r
end
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
/* else
call out sqlMsgLine(m.r.bufI0 'rows fetched', , m.r.srcTxt) */
call sqlDisConnect
return ''
endProcedure wshHook_sqlRdr
/*--- wshHook for sqlsOut read from dd wsh --------------------------*/
wshHook_sqlsOut: procedure expose m.
parse arg m, dbSys oo retOk
call errSetSayOut 'so'
call sqlSIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if oo == 'a' | oo == 't' then do
myOut = m.j.out
m.myOut.truncOk = 1
end
if \ m.sql_errRet then
call sqlsOut m.m.in, retOk, oo
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
call sqlDisConnect
return ''
endProcedure wshHook_sqlsOut
/* copy sqlS end *************************************************/
/* copy sqlCsm begin *************************************************/
sqlCsmIni: procedure expose m.
if m.sqlCsm_ini == 1 then
return
m.sqlCsm_ini = 1
call sqlOIni
call csmIni
call classNew 'n SqlCsmRdr u JRW', 'm',
, "jReset m.m.rzDb=arg; m.m.src=arg2; m.m.type=arg(4)" ,
, "jOpen call sqlCsmRdrOpen m, opt",
, "jClose" ,
, "jRead return 0"
call classNew 'n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')"
return
endProcedure sqlCsmIni
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlCsmExe:
parse arg ggRzDb, sql_query, ggRetOk
parse value dsnCsmSys(ggRzDb) with sql_host '/' sql_db2SSID
sql_query = strip(sql_query) /* csmASqls fails on leading spaces */
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
ggSqlStmt = sql_query /* for sqlMsg etc. */
if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset ------------------*/
sqlCsmRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
res = sqlCsmExe(m.m.rzDb, src, 100 retOk)
if res < 0 then
return res
if words(m.m.type) = 1 & \ abbrev(m.m.type, ' ') then
cl = class4name(m.m.type)
else if m.m.type <> '' then
cl = classNew('n* SqlCsm u f%v' m.m.type)
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsApp(vv, SQLDA_REXXNAME.kx)
end
cl = classNew('n* SqlCsm u f%v' vv)
end
ff = classFldD(cl)
if sqlD <> m.ff.0 then
return err('sqlCsmQuery sqlD' sqlD '<>' m.ff.0 'for' ,
className(cl))
do rx=1 to sqlRow#
m.m.buf.rx = m'.BUFD.'rx
call oMutate m'.BUFD.'rx, cl
end
m.m.buf.0 = sqlRow#
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
do rx=1 to sqlRow#
dst = m'.BUFD.'rx || m.ff.kx
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst = m.sqlNull
else
m.dst = value(rxNa'.'rx)
end
end
return 0
endProcedure sqlCsmRdrOpen
/* copy sqlCsm end *************************************************/
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlOIni: procedure expose m.
if m.sqlO_ini == 1 then
return
m.sqlO_ini = 1
call sqlIni
call jIni
call scanReadIni
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return sqlsOutSql(rdr, retOk, ft)"
return 0
endProcedure sqlOIni
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg src, type
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse arg sys, conCla
call sqlIni
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if conCla = 'r' | (conCla = '' & pos('/', sys) <= 0) then
conCla = m.class_sqlConn
else if conCla = 'c' | conCla = '' then
conCla = m.class_sqlCsmConn
else if conCla = 'w' then
conCla = m.class_sqlWshConn
m.sql_conCla = conCla
m.sql_conRzDB = sys
if conCla \== m.class_sqlConn then
return
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
m.m.0 = mx
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
m.m.0 = mbr_name.0
end
return mx
endProcedure mbrList
/*--- return wheter a dsn exists ------------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse arg fr, to, mbrs
if mbrs \== '' then do
if dsnGetMbr(fr) \== '' | dsnGetMbr(to) \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
/* if words(mbrs) == 1 then do ???? not necessary done in cmsCopy
parse value strip(mbrs) with old '>' new
if old = '' then
call err 'bad mbr old/new' mbrs
fr = dsnSetMbr(fr, old)
to = dsnSetMbr(to, word(new old, 1))
mbrs = ''
end
*/ end
/* currently we do everything with csm
if the need arises, implement tso only version */
return csmCopy(fr, to, mbrs)
endProcedure dsnCopy
dsnDel: procedure expose m.
parse arg aDsn, aMbrs
parse value dsnCsmSys(aDsn) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")'", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
m.csm_errMsg = strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname(csmDel)", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname(csmDel)", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName(csmDel) member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then do
call adrTso 'free dd(csmDel)'
return 0
end
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call adrTso 'free dd(csmDel)', '*'
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call adrTso 'free dd(csmDel)', '*'
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(fr) \== ''
toMbr = dsnGetMbr(to) \== ''
call csmAlloc fr, frDD, 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
/*??if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr) ???????? */
call csmAlloc to, toDD, 'shr', , ':D'frDD
/* if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end ?????????????? */
inDD = tsoDD('csmIn*', 'a')
i.0 = 0
if mbrs \== '' then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
else if \ frMbr & m.tso_dsOrg.frDD == 'PO' then do
call adrCsm "mbrList ddName("frDD") index(' ') short"
i.0 = mbr_mem#
do ix=1 to i.0
i.ix = ' S M='mbr_name.ix
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
---------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) -------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, cmd, retOk
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
tsoRc = adrtso("csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*")
if tsoRc <> 0 then
m.csm_exRxRc = tsoRc
else
m.csm_exRxRc = appc_rc
m.csm_exRx.0 = 0
if m.csm_exRxRc <> 0 then do /* handle csm error */
call mAdd csm_exRx, 'csmExRx tsoRc='tsoRc 'appc_rc='appc_rc ,
, ' rexx rz='rz 'proc='proc 'opt='opt'\n cmd='cmd ,
, ' appc_rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f ,
, ' SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ix=1 to appc_msg.0
call mAdd csm_exRx, ' ' appc_msg.ix
end
if tsoRc = 0 then
call mAdd csm_exRx ' rc=0 for tsoCmd' m.tso_stmt
else
call splitNl csm_exRx, m.csm_exRx.0,
, 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
call readDD 'rmTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmtsPrt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
call mAddSt csm_exRx, csm_tsprt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call mStrip csm_exRx, 't' */
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call saySt csm_exRx
else
call csmExRxErr
end
return m.csm_exRxRc
endProcedure csmExRx
/*--- error for last csmExRx ----------------------------------------*/
csmExRxErr: procedure expose m.
call outSt csm_exRx
call err m.csm_exRx.1
return
endProcedure csmExRxErr
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmTsPrt ' ,
'rmtwsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = oOpt
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec, '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH6' wSpec, '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc, 0 4) < 1 then call csmExRxErr;" ,
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end ******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP RQ2/DVBP' ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP Q25/DVBP' ,
'Z25/DEVG Y25/DEVG X25/DEVG'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format ----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy csv begin ****************************************************/
/**** csvRdr reads a text file, in csv format
and creates a class from column head in first line
csvRdr#jRead returns the create objects ************************/
csv2ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv2ObjRdr', 'm.m.opt = arg2' ,
, 'call csv2ObjBegin m' ,
, 'call csv2Obj m, rStem, $i'), rdr, opt)
csv2ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return m
endProcedure csvRdrOpenFinish
csv2Obj: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(translate(li, ' ', ','), 1))
call mAdd wStem, csv2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csv2Obj
/*--- convert csv line into object of class cl ----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
/*--- clear remaining fields and stems and mutate -------------------*/
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/**** csvWordRdr: similar to csvRdr, but input line format
are quoted or unquoted words ****************************/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvWordRdr', 'm.m.opt = arg2' ,
, 'call csvWordBegin m' ,
, 'call csvWord m, rStem, $i'), rdr, opt)
csvWordBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvWord: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(li, 1))
call mAdd wStem, csvWord2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csvWord
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWord2O
/**** csvColRdr: similar to csvRdr, but input format
are fixed width columns *********************************/
/*--- create object for fixLenColumns format ------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvColRdr', 'm.m.opt = arg2' ,
, 'call csvColBegin m' ,
, 'call csvCol m, rStem, $i'), rdr, opt)
csvColBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvCol: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then do
s = scanSrc(csv_colOpen, li)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
end
call mAdd wStem, csvCol2O(m, mNew(m.m.class), m.m.class, li)
return
endProcedure csvCol
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- csv4obj add a header line
and objects of the same class in csv format ---------------*/
csv4ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv4ObjRdr', ,
, 'call csv4ObjBegin m' ,
, 'call csv4Obj m, rStem, $i'), rdr, opt)
csv4ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
endProcedure csv4ObjBegin
csv4Obj: procedure expose m.
parse arg m, wStem, o
if o == '' then do
if m.m.class \== '' then
call mAdd wStem, ''
return
end
cl = objClass(o)
if cl \== m.m.class then do
if m.m.class \== '' then
return err('class('o')='cl '<>' m.m.class)
m.m.class = cl
ff = classMet(cl, 'oFlds')
if m.ff.0 < 1 then
return err('no fields in' cl)
t = ''
do fx=1 to m.ff.0
t = t','m.ff.fx
end
call mAdd wStem, substr(t, 2)
m.m.oFldD = classMet(cl, 'oFldD')
end
call mAdd wStem, csv4O(o, m.m.oFldD, 0)
return
endProcedure csv4Obj
/*--- return the csv string for an object ---------------------------*/
csv4o: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 == oNull then
res = res','
else if pos(',', v1) > 0 | pos('"', v1) > 0 | v1 == '' then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4o
/*--- fill empty fieldds with value of previous row -----------------*/
csvE2PrevRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvE2PrevRdr', 'm.m.opt = arg2' ,
, "m.m.prev = ''" ,
, 'call csvE2Prev m, rStem, $i'), rdr, opt)
/*--- externalize o and add to wStem --------------------------------*/
csvE2Prev: procedure expose m.
parse arg m, wStem, o
if o == '' then
return
ff = oFldD(o)
hasData = 0
do fx=1 to m.ff.0
f1 = o || m.ff.fx
if m.f1 \== '' then do
hasData = 1
iterate
end
if m.m.prev == '' then
iterate
p1 = m.m.prev || m.ff.fx
m.f1 = m.p1
end
if \ hasData then
return
call mAdd wStem, o
m.m.prev = o
return
endProcedure csvE2Prev
csvColBegin: procedure expose m.
/**** csvExt externalises object into csvExt format
including object cycles and classes
csv+ protocoll, first field contains meta info ---------------------
v,text null or string
w,text w-string
c name classAdr,flds class definition
b name classAdr, class forward declaration
m name adr,text method
o classAdr adr,flds object definition and output
d classAdr adr,flds object definition wihtout output
f classAdr adr, object forward declaration
r adr, reference = output of already defined objects
* text unchanged text including ' " ...
* flds csv flds
**********************************************************************/
csvExtRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvExtRdr', ,
, 'call csvExtBegin m',
, 'call csvExt m, rStem, $i'), rdr, opt)
csvExtBegin: procedure expose m.
parse arg m
d = m'.DONE'
call mapReset d, 'K'
call mapPut d, m.class_class, 'class'
call mapPut d, m.class_v, 'v'
call mapPut d, m.class_w, 'w'
call mapPut d, m.class_o, 'o'
return m
endProcedure csvExtBegin
/*--- externalize o and add to wStem --------------------------------*/
csvExt: procedure expose m.
parse arg m, wStem, o
c = objClass(o)
if c == m.class_N | c == m.class_S then
return mAdd(wStem, 'v,'o)
if c == m.class_W then
return mAdd(wStem, 'w,'substr(o, 2))
if c == m.class_class then
call csvExtClass m, wStem, o
if m.m.done.o == 0 then do
m.m.done.o = 1
call mAdd wStem, 'f' csvExtClass(m, wStem, c) o','
end
if symbol('m.m.done.o') == 'VAR' then
return mAdd(wStem, 'r' o',')
return mAdd(wStem, 'o' c o || csvExtObjTx(m, wStem, o))
endProcedure csvExt
csvExtObjTx: procedure expose m.
parse arg m, wStem, o
call mapAdd m'.DONE', o, 0
c = objClass(o)
if c \== m.class_class & pos(m.m.done.c, 12) < 1 then
call csvExtClass m, wStem, c
ff = classMet(c, 'oFldD')
r = ''
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then do
v1 = s2o(v1)
end
else if \ (c2 == m.class_N | c2 == m.class_W) then do
if m.m.done.v1 == 0 then do
m.m.done.v1 = 1
call mAdd wStem, 'f' c2 v1','
end
if symbol('m.m.done.v1') \== 'VAR' then
call mAdd wStem, 'd' c2 v1 ,
|| csvExtObjTx(m, wStem, v1)
end
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
m.m.done.o = 2
return r
endProcedure csvExtObjTx
csvExtClass: procedure expose m.
parse arg m, wStem, c
res = mapGet(m'.DONE', c, '-')
if res == 0 then do
m.m.done.c = 1
call mAdd wStem, 'b' if(m.c.name == '', '-', m.c.name) c','
return c
end
if res == 1 then
return c
if res \== '-' then
return res
call mapAdd m'.DONE', c, 0
ty = m.c
res = if(m.c.name == '', '-', m.c.name) c
if ty == 'u' then do
res = 'c' res',u'
if m.c.0 > 0 then do
r = ''
do cx=1 to m.c.0
r = r','csvExtClassEx(m, wStem, m.c.cx)
end
res = res substr(r, 2)
end
end
else if ty == 'm' & m.c.0 == 0 then
res = 'm' res','m.c.met
else
res = 'c' res','csvExtClassEx(m, wStem, c)
call mAdd wStem, res
call mapPut m'.DONE', c, c
return c
endProcedure csvExtClass
csvExtClassEx: procedure expose m.
parse arg m, wStem, c
res = ''
ch = c
do forever
g = mapGet(m'.DONE', c, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res csvExtClass(m, wStem, ch))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('csvExtClassEx bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure csvExtClassEx
/*--- convert variable len recs to fixLen
& = continuation, | end (to protect ' &|') -------------------*/
csvV2FRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvV2FRdr', 'm.m.maxLen = arg2',
, 'call csvV2FBegin m, m.m.maxLen',
, 'call csvV2F m, rStem, $i'), rdr, arg)
csvV2FBegin: procedure expose m.
parse arg m, maxL
m.m.maxLen = word(maxL 55e55, 1)
return m
endProcedure csvV2FBegin
csvV2F: procedure expose m.
parse arg m, wStem, line
if line \== '' & pos(right(line, 1), ' &|') > 0 then
line = line'|'
if length(line) <= m.m.maxLen then
return mAdd(wStem, line)
do cx=1 by m.m.maxLen-1 to length(line)-m.m.maxLen
call mAdd wStem, substr(line, cx, m.m.maxLen-1)'&'
end
return mAdd(wStem, substr(line, cx))
endProcedure csvV2F
/*--- f2v fixLen to variable len lines: &=continuation |=endMark ----*/
csvF2VRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvF2VRdr', ,
, 'call csvF2VBegin m' ,
, 'call csvF2V m, rStem, $i' ,
, 'call csvF2VEnd m'), rdr, arg)
csvF2VBegin: procedure expose m.
parse arg m
m.m.strt = ''
return m
endProcedure csvF2VBegin
csvF2V: procedure expose m.
parse arg m, wStem, aLi
li = strip(aLi, 't')
if right(li, 1) == '&' then do
m.m.strt = m.m.strt || left(li, length(li) - 1)
return
end
if right(li, 1) == '|' then
call mAdd wStem, m.m.strt || left(li, length(li) - 1)
else
call mAdd wStem, m.m.strt || li
m.m.strt = ''
return
endProcedure csvF2V
csvF2VEnd: procedure expose m.
parse arg m
if m.m.strt \== '' then
return err("csvF2vEnd but strt='"m.m.strt"'")
return m
endProcedure csvF2VEnd
/*--- internalize objects in ext format -----------------------------*/
csvIntRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvIntRdr', ,
, 'call csvIntBegin m',
, 'call csvInt m, rStem, $i'), rdr, opt)
csvIntBegin: procedure expose m.
parse arg m
m.m.forward = ''
d = m'.DONE'
call mapReset d, 'K'
return
endProcedure csvIntBegin
csvInt: procedure expose m.
parse arg m, wStem, line
parse var line hd ',' rest
parse var hd h1 h2 h3 hr
d = m'.DONE'
if pos(h1, 'vwr') > 0 then do
if m.m.forward \== '' then
return err('csvInt: forward='m.m.forward 'not empty:' line)
if h1 == 'v' & h2 == '' then
return mAdd(wStem, rest)
if h1 == 'w' & h2 == '' then
return mAdd(wStem, m.o_escW || rest)
if h1 \== 'r' | h2 == '' | h3 \== '' | rest \== '' then
return err('csvInt: bad line' line)
r = mapGet(d, h2, '')
if r == '' then
return err('csvInt: undefined reference' line)
return mAdd(wStem, r)
end
if h3=='' | hr\=='' | length(h1)\==1 | pos(h1, 'bcmdfo') < 1 then
return err('csvInt: bad line' line)
if h1 == 'b' | h1 == 'f' then do
if symbol('m.d.h3') == 'VAR' then
return err('csvInt: forward already defined:' line)
if h1 == 'b' then do
if h2 == '-' then
h2 = 'CsvForward'
n = classNew('n' h2 || (m.class.0+1) 'u')
m.n.met = h2'*'
end
else do
cl = mapGet(d, h2, '')
if cl == '' then
return err('csvInt: undefined class:' line)
n = mNew(cl)
end
call mapAdd d, h3, n
m.m.forward = m.m.forward h3
return
end
if h1 == 'm' then do
n = classNew('m' h2 rest)
return mapAdd(d, h3, n)
end
if h1 == 'c' then do
rx = 1
rr = ''
do while rx <= length(rest)
ry = pos(',', rest, rx+1)
if ry < 1 then
ry = length(rest)+1
r1 = substr(rest, rx, ry-rx)
rI = wordIndex(r1, words(r1))
if rI == 1 & abbrev(r1, ',') then
rI = 2
rL = strip(substr(r1, rI))
if length(rL) \== 1 | pos(rL, 'vwor') < 1 then do
rL = mapGet(d, rL, '')
if rL == '' then
return err('csvInt undef class' rL 'line:' line)
end
rr = rr || left(r1, rI-1)rL
rx = ry
end
end
fx = wordPos(h3, m.m.forward)
if fx > 0 then do
m.m.forward = strip(delWord(m.m.forward, fx, 1))
n = mapGet(d, h3)
if h1 == 'c' then do
call classNew 'n=' m.n.name rr
call classMet n, 'new'
return
end
cl = 'CLASS'substr(n, 2, pos('.', n, 3)-2)
if cl \== mapGet(d, h2) then
return err('csvInt: forward class' cl 'mismatches' line)
end
else do
if mapHasKey(m, d, h3) then
return err('already defined:' line)
if h1 == 'c' then do
do while datatype(right(h2, 1), 'n')
h2 = left(h2, length(h2)-1)
end
if h2 == '-' then
h2 = 'CsvForward'
s = ''
cl = classNew(copies('n*' h2' ', h2 \== '-')rr)
call classMet cl, 'new'
return mapAdd(d, h3, cl)
end
cl = mapGet(d, h2, '')
if cl == '' then
return err('undefined class:' line)
n = mNew(cl)
call mapAdd d, h3, n
end
call csv2o n, cl, rest
ff = classFldD(cl)
do fx=1 to m.ff.0
f1 = n || m.ff.fx
c1 = m.ff.fx.class
if m.c1 \== 'r' | m.f1 == '' | abbrev(m.f1, m.o_escW) then
iterate
t1 = mapGet(d, m.f1, '')
if t1 == '' then
return err('missing reference' fx m.f1 'in' line)
m.f1 = t1
end
if h1 == 'o' then do
if m.m.forward \== '' then
call err 'forward not empty:' line
call mAdd wStem, n
end
return
endProcedure csvInt
/* copy csv end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'",
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 > 0 then do" ,
"; wStem = m''.BUF'';' classMet(cl, 'jWriteMax')'; end;'",
"'wStem = qStem;' classMet(cl, 'jWrite')" ,
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0; say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end ********************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2StrZYX return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2StrZYX return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "o2String return classGenO2Str(cl)" ,
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
/* 'o2Text ?r return m"=¢?:!"' */
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
) /* , 'o2StrZYX return m') */
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''"
/* 'o2Text ?r return m"=¢?:!"' */
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classGenO2Str: procedure expose m.
parse arg cl
if cl == m.class_v then
return "return m.m"
else if cl == m.class_w then
return "return substr(m, 2)"
else if cl == m.class_s then
return "return m"
else
return "\-\"
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end **************************************************/
/* copy mapExp begin *************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* 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>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy fTab begin *****************************************************
output Modes: t = tableMode 1 line per object with fixed colums th
c = colMode 1 line per column/field of object
we build a format for each column
and a set of title lines, one sequence printed before
, one sequence printed after
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * fTabAdd * add col info
sqlFTabOthers ?
fTabGenTab or fTabGenCol
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
primary data for each col
.col : column (rexx) name plus aDone
.done : == 0 sqlFtabOthers should add it again
.fmt : format
.labelLo : long label for multi line cycle titles
.labelSh : short label for singel title line (colwidth)
.tit.* : title line piece for this col
**********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.0 = 0
m.m.set.0 = 0
return fTabResetCols(oMutate(m, m.fTab_class))
endProcedure fTabReset
/*--- clean out all cols of ftab, but keep settings -----------------*/
fTabResetCols: procedure expose m.
parse arg m
m.m.0 = 0
return m
/*--- for column cx set title tx ------------------------------------*/
fTabSetTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if tx > m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabSetTit
/*--- set default atts for a col name ------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, sh, lo
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelSh = sh
m.m.set.sx.labelLo = lo
m.m.set.c1 = sx
return
endProcedure fTabSet
/*--- add a column --------------------------------------------------
m, rexxName done, fmt, labelShort, labelLong, titles... -------*/
fTabAdd: procedure expose m.
parse arg m, rxNm aDone
m.m.generated = ''
cx = m.m.0 + 1
m.m.0 = cx
cc = m'.'cx
m.cc.col = rxNm
m.cc.done = aDone \== 0
parse arg , , m.cc.fmt, m.cc.labelSh, m.cc.labelLo
if rxNm == '=' | rxNm == 0 | rxNm == 1 then
call err 'bad rxNm' rxNm
if \ (aDone == '' | aDone == 0 | aDone == 1) then
call err 'bad aDone' aDone
m.cc.tit.0 = max(arg()-4, 1)
m.cc.tit.1 = ''
do tx=2 to m.cc.tit.0
m.cc.tit.tx = arg(tx+4)
end
return cc
endProcedure fTabAdd
/*--- complete column info-------------------------------------------*/
fTabColComplete: procedure expose m.
parse arg m
do cx=1 to m.m.0
nm = m.m.cx.col
f1 = m.m.cx.fmt
if f1 = '' then
m.m.cx.fmt = '@.'nm'%-8C'
else do
px = pos('%', f1)
ax = pos('@', f1)
if px > 0 & (ax <= 0 | ax >= px) then
m.m.cx.fmt = left(f1, px-1)'@.'nm || substr(f1, px)
end
if m.m.cx.labelLo = '' then
if nm = '' then
m.m.cx.labelLo = '='
else
m.m.cx.labelLo = nm
if m.m.cx.labelSh = '' then
m.m.cx.labelSh = m.m.cx.labelLo
end
return
endProcedure fTabColComplete
/*--- generate line formats and title lines -------------------------*/
fTabGenTab: procedure expose m.
parse arg m, sep
if m.m.generated == '' then
call fTabColComplete m
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
f = ''
tLen = 0
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelSh
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelSh) < 1 then /* corrupted| */
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelSh, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fCache('%.', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
/*try with cycle lines for cSta to cEnd */
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelLo
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelLo
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelLo) ,
= translate(m.m.kx.labelSh)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenTab
/*--- generate column format ----------------------------------------*/
fTabGenCol: procedure expose m.
parse arg m
if m.m.generated == '' then
call fTabColComplete m
do kx=1 to m.m.0
t = m.m.kx.labelLo
l = if(m.m.kx.labelSh == t, , m.m.kx.labelSh)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabGenCol
/*--- output all of rdr in tab format -------------------------------*/
fTab: procedure expose m.
parse arg m, rdr
if pos('a', m.m.opt) < 1 then
i = rdr
else do
i = in2Buf(rdr)
if m.i.buf.0 > 0 then
call fTabDetect m, i'.BUF'
end
if pos('o', m.m.opt) > 0 then do
call pipeWriteAll i
end
else if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
i = jOpen(in2file(i), '<')
do rx=1 while jRead(i)
call out left('--- row' rx '', 80, '-')
call fTabCol m, m.i
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
call jClose i
end
else do
call fTabBegin m
call fAll m.m.fmt, i
return fTabEnd(m)
end
return m
endProcedure fTab
/*--- output object i in col format ---------------------------------*/
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenTab m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr
if m == '' then
m = fTabReset(f_auto, 1, , 'a')
else if pos('a', m.m.opt) < 1 then
m.m.opt = 'a'm.m.opt
return fTab(m, rdr)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
do cx=1 to m.m.0
rxNm = m.m.cx.col
done.rxNm = m.m.cx.done
if m.m.cx.fmt == '' then
m.m.cx.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
rxNm = substr(m.ff.fx, 2)
if done.rxNm \== 1 then do
cc = fTabAdd(m, rxNm)
m.cc.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabDetectFmt: procedure expose m.
parse arg st, suf
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
return '%'newFo
endProcedure fTabDetectFmt
/* copy fTab end ***************************************************/
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fCache ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.ggFmt
endProcedure fImm
fCacheNew: procedure expose m.
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
return '%.'m.f_gen0
endProcedure fCacheNew
/*--- compile format fmt put in the cache with address a ------------*/
fCache: procedure expose m.
parse arg a, fmt
if a == '%.' then
a = fCacheNew()
else if symbol('M.f_gen.a') == 'VAR' then
return a
cy = -2
nm = ' '
gen = ' '
opt = 0
do forever /* split preprocesser clauses */
cx = cy+3
cy = pos('%#', fmt, cx)
if cy < 1 then
act = substr(fmt, cx)
else
act = substr(fmt, cx, cy-cx)
do ax=1
ay = pos('%&', act)
if ay < 1 then
leave
ct = substr(act, ay+2, 1)
if symbol('f.ct') \== 'VAR' then
call err 'undefined %&'ct 'in format' fmt
act = left(act, ay-1) || f.ct || substr(act, ay+3)
if ax > 100 then
say 'fGen' fmt nm '==>' act 'actPos' substr(fmt, cx)
end
if cy <> 1 & (\ opt | symbol('f.nm') \== 'VAR') then
f.nm = act
if cy < 1 | length(fmt) <= cy+1 then
leave
nm = substr(fmt, cy+2, 1)
opt = nm == '?'
if pos(nm, '?;#') > 0 then do
if nm == '#' then do
if length(fmt) <> cy+3 then
call err 'fCache bad %##'nm 'in' fmt
else if a == fmt then
a = left(a, cy-1)
leave
end
cy = cy+1
nm = substr(fmt, cy+2, 1)
if nm == ';' then do
gen = nm
iterate
end
end
if pos(nm, m.ut_alfa' ') < 1 then
call err 'fCache bad name %#'nm 'in' fmt
if pos(nm, gen) < 1 then
gen = gen || nm
end
if symbol('m.f_s_0') \== 'VAR' | m.f_s_0 == 0 then
m.f_s_0 = 1
else do
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
end
do cx=1 to length(gen)
nm = substr(gen, cx, 1)
act = f.nm
a2 = a
if nm == ' ' then
a2 = a
else
a2 = a'%##'nm
call scanSrc f_s, act
m.f_gen.a2 = fGen(f_s)
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
end
m.f_s_0 = m.f_s_0 - 1
return a
endProcedure fCache
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fCache
%#v before contents of variable v (1 alfa or 1 space),
stored at address%##v
%#?v define variable v if not yet defined
%#; restart of variables to generate
%&v use of previously defined variable v
---------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg f_s
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
if scanWhile(f_s, '0123456789') then
len = m.f_s.tok
else
len = ''
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," word(prec 0, 1)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," word(prec 0, 1)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnits("aa", '"m.f_s.tok"'," len"," prec pl")"
end
/* else if sp = '(' then do
if af == '' | flags \== '' | len \== 0 | prec \== '' then
call scanErr f_s, "bad call shoud be @sub%("
interpret "cRes = fGen"af"(f_s, ax)"
cd = cd '||' cRes
if \ scanLit(f_s, '%)') then
if \ scanEnd(f_s) then
call scanErr f_s, '%) to end call' af 'expected'
end */
else do
call scanBack f_s, '%'sp
leave
end
end
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGen
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if \ scanLit(f_s, '%%', '%@') then
return res
res = res || substr(m.f_s.tok, 2)
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGen: procedure expose m.
parse arg c 2 d, s
/* special L = LRSN in Hex
l = lrsn (6 or 10 Byte) */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
a = 'F_TSTFO.'
/* Y: year A = 2010 ...
M: month B=Januar ...,
H: hour A=0 B=10 C=20 D=30 */
m.f_tst_N0 = 'yz345678 hi:mn:st'
m.f_tst_N = 'yz345678 hi:mn:st.abcdef'
m.f_tst_S0 = 'yz34-56-78-hi.mn.st'
m.f_tst_S = 'yz34-56-78-hi.mn.st.abcdef'
call mPut a'S', m.f_tst_S
call mPut a's', m.f_tst_S0
call mPut a' ', m.f_tst_S0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78'
call mPut a'M', 'M78himns'
call mPut a'A', 'A8himnst'
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tst_N0
call mPut a'N', m.f_tst_N
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGen(cd, s)
end
if c == ' ' then do
if pos(d, 'SN') > 0 then
return fTstgFi(m.f_tst_N, m.f_tstFo.d,
, "date('S') time('L')")
else if pos(d, 'sMAn ') > 0 then
return fTstgFi(m.f_tst_N0, m.f_tstFo.d,
, "date('S') time()")
else if pos(d, 'DdEeY') > 0 then
return fTstgFi(mGet('F_TSTFO.D'), m.f_tstFo.d, "date('S')")
else if pos(d, 'tH') > 0 then
return fTstgFi(mGet('F_TSTFO.t'), m.f_tstFo.d, "time()")
else if pos(d, 'T') > 0 then
return fTstgFi(mGet('F_TSTFO.T'), m.f_tstFo.d, "time('L')")
else
call err 'fTstGen implement d='d
end
return fTstgFi(m.f_tstFo.c, m.f_tstFo.d, s)
endProcedure fTstGen
fTstgFi: procedure expose m.
parse arg f, d, s
code = fTstgFF(f, d, s)
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCacheNew()
m.f_gen.a = 'return' repAll(s, '$', 'ggA1')
return "fImm('F_GEN."a"'," s")"
endProcedure fTstFi
fTstgFF: procedure expose m.
parse arg f, t, s
if verify(f, 'lLjJu', 'm') > 0 then do
if f == 'l' then do
if t == 'l' then
return 'timeLrsn10('s')'
else if t == 'L' then
return 'c2x(timeLrsn10('s'))'
else if verify(t, 'lL', 'm') = 0 then
return fTstFi(m.fTst_fo.S, t, 'timeLrsn2LZT('s')')
end
call err 'fTstgFF implement' f 'to' t
end
if symbol('m.F_TSTSCAN') == VAR then
m.f_tstScan = m.f_tstScan + 1
else
m.f_tstScan = 1
a = f_tstScan || m.f_tstScan
call scanSrc a, t
cd = ''
toNull = 'imnstabcdef78'
if verify(f, 'hH', 'm') = 0 then
toNull = toNull'hH'
if verify(f, 'M56', 'm') = 0 then
toNull = toNull'M56'
if verify(f, 'yz34Y', 'm') = 0 then
toNull = toNull'yz34Y'
do while \ scanEnd(a)
c1 = ''
do forever
if scanVerify(a, f' .:-', 'n') then do
c1 = c1 || m.a.tok
end
else if pos(scanLook(a, 1), toNull) > 0 then do
call scanChar a, 1
c1 = c1 || translate(m.a.tok, '00000000000010A?010001?',
, 'imnstabcdef78hHM56yz34Y')
end
else do
if c1 == '' then
nop
else if c1 == f then
c1 = s
else if pos(c1, f) > 0 then
c1 = "substr("s"," pos(c1, f)"," length(c1)")"
else
c1 = "translate('"c1"'," s", '"f"')"
leave
end
end
if c1 \== '' then do
end
else if scanVerify(a, 'yz34Y', 'n') then do
t1 = m.a.tok
if pos('yz34', f) > 0 then
c1 = "substr("s "," pos('yz34', f)", 4)"
else if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
if t1 = '34' then
c1 = "substr("c1", 3)"
else if t1 = 'Y' then
c1 = "timeYear2Y("c1")"
end
else if scanVerify(a, '56M', 'n') then do
if m.a.tok == '56' & pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
else if m.a.tok == 'M' & pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if scanVerify(a, 'hiH', 'n') then do
if m.a.tok == 'hi' & pos('Hi', f) > 0 then
c1 = "timeH2Hour(substr("s"," pos('Hi', f)", 2))"
else if m.a.tok == 'Hi' & pos('hi', f) > 0 then
c1 = "timeHour2H(substr("s"," pos('hi', f)", 2))"
end
else if scanLit(a, 'jjjjj') then do
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if scanLit(a, 'JJJJJJ') then do
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if scanLit(a, copies('l', 10), copies('L', 20),
, 'uuuuuuuu') then do
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tst_S, s)")"
if abbrev(m.a.tok, 'l') then
c1 = "x2c("c1")"
else if abbrev(m.a.tok, 'u') then
c1 = "timeLrsn2Uniq("c1")"
end
else do
call scanChar a, 1
c1 = "'implement "m.a.tok"'"
/* call err 'implement' */
end
if c1 == '' then
call scanErr a, 'fTstGFF no conversion from' f
cd = cd "||" c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
fWords: procedure expose m.
parse arg fmt, wrds
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if wrds = '' then
return f(f2'%##e')
res = f(f2'%##a', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if tx < fx then
return f(f2'%##e')
res = f(f2'%##a', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res
endProcedure fCatFT
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5m43 -------*/
fUnits: procedure expose m.
parse arg v, scale, aLen, aPrec, plus
if \ dataType(v, 'n') then do
f1 = fUnitsF1(v, scale, aLen, length(plus), length(plus), aPrec)
return right(v, m.f1.len)
end
if v >= 0 then
sign = plus
else
sign = '-'
v = abs(v) /* always get rid also of sign of -0 | */
f1 = fUnitsF1(v, scale, aLen, length(plus), length(sign), aPrec)
do forever
w = format(v * m.f1.fact, , m.f1.prec)
if pos('E-', w) > 0 then
w = format(0, , m.f1.prec)
if w < m.f1.lim2 then do
if m.f1.kind == 'r' then
x = sign || w || m.f1.unit
else if m.f1.kind == 'm' then
x = sign || (w % m.f1.mod) || m.f1.unit ,
|| right(w // m.f1.mod, m.f1.len2, 0)
else
call err 'bad kind' m.f1.kind 'in f1' f1
if length(x) <= m.f1.len then
return right(x, m.f1.len)
end
if m.f1.next == '' then
return left(sign, m.f1.len, '+')
f1 = m.f1.next
end
endProcedure fUnits
fUnitsF1: procedure expose m.
parse arg v, scale, len, pLen, sLen, aPrec
slp = 'F_Unit.'scale'.'len'.'pLen'.'sLen'.'aPrec
if symbol('m.slp.0') \== 'VAR' then do
sc = 'F_Unit.'scale
if symbol('m.sc.0') \== 'VAR' then do
call fUnitsF1Ini1
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc
end
if scale = 'd' | scale = 'b' then do
if aPrec == '' then
aPrec = 0
if len = '' then
len = aPrec + (aPrec >= 0) + 4 + pLen
dLen = len - sLen
l2 = '1e' || (dLen - aPrec - (aPrec > 0))
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, l2, len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = aPrec
m.si.next = slp'.' || (x+1)
end
if aPrec > 0 then do
y = x-1
si = fUnitsF1I0(slp, x, m.sc.y.kind, m.sc.y.unit,
, m.sc.y.fact, ('1e' || dLen), len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
end
end
else if scale = 't' then do
if len = '' then
len = 5 + pLen
dLen = len - sLen
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, m.sc.x.lim2, len ,
, m.sc.x.mod, m.sc.x.len2)
if x = m.sc.0 - 1 then
m.si.lim2 = '24e' || (dLen-3)
else if x = m.sc.0 then
m.si.lim2 = '1e' || (dLen-1)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
m.si.next = slp'.' || (x+1)
end
end
else
call err implement
x = m.slp.0
m.slp.x.next = ''
end
if \ datatype(v, 'n') then
return slp'.nn'
do q=11 to m.slp.0-1 while v >= m.slp.q.lim1
end
if q = 11 & v <> trunc(v) then do
do q=10 by -1 to m.slp.min+1 while v < m.slp.q.lim1
end
q = q + 1
end
return slp'.'q
endProcedure fUnitsF1
fUnitsF1Ini1: procedure expose m.
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = 'F_Unit.b'
sD = 'F_Unit.d'
sT = 'F_Unit.t'
fB = 1
fD = 1
call fUnitsF1i0 sB, 11, 'r', ' ', fB
call fUnitsF1i0 sD, 11, 'r', ' ', fD
do x=1 to 6
fB = fB * 1024
/* call fUnitsF1i0 sB, 11-x, 'r', substr(iso, 11-x, 1), fB */
call fUnitsF1i0 sB, 11+x, 'r', substr(iso, 11+x, 1), 1/fB
fD = fD * 1000
call fUnitsF1i0 sD, 11+x, 'r', substr(iso, 11+x, 1), 1/fD
call fUnitsF1i0 sD, 11-x, 'r', substr(iso, 11-x, 1), fD
end
call fUnitsF1i0 sT, 11, 'm', 's', 100, 6000, , 100, 2
call fUnitsF1i0 sT, 12, 'm', 'm', 1, 3600, , 60, 2
call fUnitsF1i0 sT, 13, 'm', 'h', 1/60, 1440, , 60, 2
call fUnitsF1i0 sT, 14, 'm', 'd', 1/3600, , , 24, 2
call fUnitsF1i0 sT, 15, 'r', 'd', 1/3600/24
return
endProcedure fUnitsF1Ini1
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, m.si.unit, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
if \ datatype(ix, 'n') then
return si
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
parse source m.err_os .
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then
interpret m.err_handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay then
call saySt st
if m.err_sayOut & \ (m.err_saysay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = word(sx 1, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/-
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/
/* copy tstAll begin ************************************************/
tstAll: procedure expose m.
say 'tstAll' m.myWsh '8.7.16...............'
call tstBase
call tstComp
call tstDiv
if m.err_os = 'TSO' then do
call tstZos
call tstTut0
end
return 0
endProcedure tstAll
/****** tstZos *******************************************************/
tstZOs:
call tstTime
call tstTime2Tst
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csmRZ \== '' then do
call tstSqlCsm
call tstSqlWsh
call tstSqlWs2
end
call scanReadIni
call tstSqlCall
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqlS1
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstSqlFTab5
call tstsql4obj
call tstdb2Ut
call tstMain
call tstHookSqlRdr
call tstCsmExWsh
call tstTotal
return
endProcedure tstZOs
/*--- manualTest for csi --------------------------------------------*/
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DSN.**'
call tstCsiNxCl 'DP4G.**'
end
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
*** err: adrTso rc=8 stmt=LISTDS 'A540769.TMP.TST.MBRLIST' MEMBERS+
. .
. e 1: A540769.TMP.TST.MBRLIST
. e 2: IKJ58503I DATA SET 'A540769.TMP.TST.MBRLIST' NOT IN CATAL+
OG
#noPds: 0 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST( *IE* )
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST( *?IE* )
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"( *IE* )", '#*IE*'
call tstMbrList1 pds"( *?IE* )", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/****** tstDiv *******************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err_os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiDs(org) ORG.U0009.B0106.MLEM43
iiDs(db2) DSN.DB2
iiRz2C(RZ2) 2
*** err: no key=R?Y in II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no key=D??? in II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
*** err: no key=M6R in II_MBR2DB
errHan======= mbr2DbSys(m6r?) 0
errHandlerPush Mbr2DbSys(m7r?) ?no?dbSys?
*** err: no key=M8R in II_MBR2DB
errHandlerPop Mbr2DbSys(m8r?) 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiDs(org) ' iiDs('oRg')
call tstOut t, 'iiDs(db2) ' iiDs(db2)
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixPut' iiIxPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstOut t, "errHan======= mbr2DbSys(m6r?)" iiMbr2DbSys('m6r?')
call errHandlerPushRet "?no?dbSys?"
call tstOut t, "errHandlerPush Mbr2DbSys(m7r?)" iiMbr2DbSys('m7r?')
call errHandlerPop
call tstOut t, "errHandlerPop Mbr2DbSys(m8r?)" iiMbr2DbSys('m8r?')
call tstEnd t
return
endProcedure tstII
tstTime2tst: procedure expose m.
/*
$=/tstTime2tst/
### start tst tstTime2tst #########################################
2015-05-13-23.45.57.987654 ==> 735730.99025448673611 ==> 2015-05-13+
-23.45.57.987654 1
1956-04-01-23.59.59.999999 ==> 714139.99999999998843 ==> 1956-04-01+
-23.59.59.999999 1
2016-02-29-12.34.56.789087 ==> 736022.52426839221065 ==> 2016-02-29+
-12.34.56.789087 1
1567-08-23-19.59.59.999999 ==> 572203.83333333332176 ==> 1567-08-23+
-19.59.59.999999 1
$/tstTime2tst/
*/
call tst t, 'tstTime2tst'
l = '2015-05-13-23.45.57.987654 1956-04-01-23.59.59.999999' ,
'2016-02-29-12.34.56.789087 1567-08-23-19.59.59.999999'
do lx=1 to 4
v = word(l, lx)
w = timeDays2tst(timestamp2days(v))
call tstOut t, v '==>' timestamp2days(v) '==>' w (v = w)
end
call tstEnd t
return
endProcedure tstTime2tst
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
05-28-00.00 2days 735745
05-28-04.00 2days 735745.16666666666667
05-28-21.00 2days 735745.9
05-29-00.00 2days 735746
16-05-28-00 2days 736111
16...12 - 15...06 366.25000000000000
2016-05-28-12.23.45 .
2016-05-28-12-23.45 bad timestamp 2016-05-28-12-23
2016.05-28-12.23.45 bad timestamp 2016.05-28-12.23
2016-05-28-12.23.45.987654 .
2016-0b-28-12.23.45 bad timestamp 2016-0b-28-12.23
2016-05-28-12.23.45.9876543 bad timestamp 2016-05-28-12.23
2016-05-28-12.23.45.98-654 bad timestamp 2016-05-28-12.23
2016-00-28-12.23.45 bad month in timestamp 2016-00
2016-05-28-13.23.45 .
2016-15-28-12.23.45 bad month in timestamp 2016-15
2016-05-31-12.23.45 .
2016-04-31-13.23.45 bad day in timestamp 2016-04-3
2015-04-30-12.23.45 .
2016-02-30-12.23.45 bad day in timestamp 2016-02-3
2016-02-29-13.23.45 .
2015-02-29-12.23.45 bad day in timestamp 2015-02-2
2016-07-30-25.00.00 bad hour in timestamp 2016-07-
2016-04-07-24.00.00.0 .
2015-02-19-24.00.01 bad hour in timestamp 2015-02-
Achtung: output haengt von Winter/SommerZ & LeapSecs ab
stckUnit = 0.000000000244140625
timeLeap = 00000018CBA80000 = 106496000000 = 26.000 secs
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
timeUQZero = 207090001374976
timeUQDigis = 35 digits ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2TAI10(00C5E963363741000000) 2010-05-01-10.35.20.789008
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
Lrsn2TAI10(TAI102Lrsn(2011-03-31-14.35.01.234567) +
2011-03-31-14.35.01.234567
TAI102Lrsn(Lrsn2TAI10(00C5E963363741000000) 00C5E963363741000000
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34567
LZt2Stc(Lrsn2LZt(00C5E963363741000000) 00C5E963363741000000
Lrsn2uniq(00C5E963363741000000) CTNR6S7T back 00C5E963363740000000
Lrsn2LZt(LZt2Lrsn(2051-10-31-14.35.01.234567) 2051-10-31-14.35.01+
..234567
Lrsn2TAI10(01010000000000000000) 2043-04-09-14.36.53.414912
$/tstTime/
Winterzeit
timeZone = 00000D693A400000 = 14745600000000 = 3600.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
Sommerzeit
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
*/
call jIni
call timeIni
call tst t, 'tstTime'
call out '05-28-00.00 2days ' timestamp2days('2015-05-28-00.00.00')
call out '05-28-04.00 2days ' timestamp2days('2015-05-28-04.00.00')
call out '05-28-21.00 2days ' timestamp2days('2015-05-28-21.36.00')
call out '05-29-00.00 2days ' timestamp2days('2015-05-29-00.00.00')
call out '16-05-28-00 2days ' timestamp2days('2016-05-28-00.00.00')
call out '16...12 - 15...06 ' timestampDiff( '2016-05-28-12.23.45',
, '2015-05-28-06.23.45')
l = '2016-05-28-12.23.45 2016-05-28-12-23.45 2016.05-28-12.23.45',
'2016-05-28-12.23.45.987654 2016-0b-28-12.23.45' ,
'2016-05-28-12.23.45.9876543 2016-05-28-12.23.45.98-654' ,
'2016-00-28-12.23.45 2016-05-28-13.23.45 2016-15-28-12.23.45',
'2016-05-31-12.23.45 2016-04-31-13.23.45 2015-04-30-12.23.45',
'2016-02-30-12.23.45 2016-02-29-13.23.45 2015-02-29-12.23.45',
'2016-07-30-25.00.00 2016-04-07-24.00.00.0 2015-02-19-24.00.01'
do lx=1 to words(l)
call out left(word(l, lx), 30),
strip(left(timestampCheck(word(l, lx)), 30), 't')
end
t1 = '2011-03-31-14.35.01.234567'
t2 = '2051-10-31-14.35.01.234567'
s1 = timeLrsnExp('C5E963363741')
s2 = timeLrsnExp('0101')
call out 'Achtung: output haengt von Winter/SommerZ & LeapSecs ab'
numeric digits 15
call out 'stckUnit =' m.time_StckUnit
call out 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
call out 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
/* call out "cvtext2_adr =" d2x(cvtExt2A, 8) */
call out 'timeUQZero =' m.time_UQZero
call out 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2TAI10('s1')' timelrsn2TAI10(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'TAI102Lrsn('t1')' timeTAI102Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2TAI10(TAI102Lrsn('t1')' ,
timeLrsn2TAI10(timeTAI102Lrsn(t1))
call out 'TAI102Lrsn(Lrsn2TAI10('s1')' ,
timeTAI102Lrsn(timelrsn2TAI10(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t2')' timeLrsn2LZt(timeLZt2Lrsn(t2))
call out 'Lrsn2TAI10('s2')' timelrsn2TAI10(s2)
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
tstCsmExWsh: procedure expose m.
/*
new lines: 24
$=/tstCsmExWsh/
### start tst tstCsmExWsh #########################################
--- sending v
line eins aus <toRZ>
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei!
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, und !
line vier end
--- sending e
line eins aus <toRZ>
tstR: @tstWriteoV2 isA :TstCsmExWsh*3
tstR: .fEins = o1Feins
tstR: = o1Val
tstR: .fZwei = o1 fZwei
tstR: @tstWriteoV4 isA :TstCsmExWsh*3
tstR: .fEins = o2Feins
tstR: = o2Value
tstR: .fZwei = o2,fwei, und .
line vier end
--- sending f50
line eins aus <toRZ> .
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei! .
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, ...!
line vier end .
$/tstCsmExWsh/
*/
call csmIni
call pipeIni
call tst t, "tstCsmExWsh"
call mAdd t.trans, m.tst_csmRz '<toRZ>'
bi = jBuf("$$- 'line eins aus' sysvar(sysnode)" ,
, "cc = classNew('n? TstCsmExWsh u f fEins v, v, f fZwei v')" ,
, "$$. csv2o('csm_o1',cc, 'o1Feins,o1Val,o1 fZwei')" ,
, "$$. csv2o('csm_o2',cc, 'o2Feins,o2Value,""o2,fwei, und ""')" ,
, "$$ line vier end")
call out '--- sending v'
call csmExWsh m.tst_csmRz, bi, 'v'
ww = oNew(m.class_csmExWsh, m.tst_csmRz, bi, 'e')
call out '--- sending e'
call jWriteAll t, ww
call out '--- sending f50'
call csmExWsh m.tst_csmRz, bi, 'f50'
call tstEnd t
return
endProcedure tstCsmExWsh
/****** tstSql *******************************************************/
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCall: procedure expose m.
/*
$=/tstSqlCall/
### start tst tstSqlCall ##########################################
set sqlid 0
drop proc -204
crea proc 0
call -2 0
resultSets 1 vars=3 2=-1 3=call-2 -2
* resultSet 1 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call-2 a3=
call -1 0
resultSets 1 vars=3 2=0 3=call-1 -1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call-1 a2= a3=
call 0 0
resultSets 0 vars=3 2=1 3=call0 0
call 1 0
resultSets 1 vars=3 2=2 3=call1 1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call1 a2= a3=
call 2 0
resultSets 2 vars=3 2=3 3=call2 2
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call2 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call2 a3=
call 3 0
resultSets 3 vars=3 2=4 3=call3 3
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call3 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call3 a3=
* resultSet 3 CUR NAME A3
rollback 0
$/tstSqlCall/ */
call tst t, "tstSqlCall"
prc = 'qz91WshTst1.proc1'
c1 = "from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'" ,
"order by colNo" ,
"fetch first"
call sqlConnect
call tstOut t, 'set sqlid' ,
sqlUpdate(3, "set current sqlid = 'S100447'")
call tstOut t, 'drop proc' sqlUpdate(3, 'drop procedure' prc)
call sqlCommit
call tstOut t, 'crea proc' sqlUpdate(3, 'create procedure' prc ,
"(in a1 varchar(20), inOut cnt int, out res varchar(20))" ,
"version v1 not deterministic reads sql data" ,
"dynamic result sets 3" ,
"begin" ,
"declare prC1 cursor with return for" ,
"select 'cur1' cur, name, colType, length, left(a1, 7) a1" ,
c1 "1 rows only;" ,
"declare prC2 cursor with return for" ,
"select 'cur2' cur, name, colType, left(a1, 7) a2" ,
c1 "3 rows only;" ,
"declare prC3 cursor with return for" ,
"select 'cur2' cur, name, left(a1, 7) a3" ,
"from sysibm.sysTables where 1 = 0;" ,
"if cnt >= 1 or cnt = -1 then open prC1; end if;" ,
"if cnt >= 2 or cnt = -2 then open prC2; end if;" ,
"if cnt >= 3 or cnt = -3 then open prC3; end if;" ,
"set res = strip(left(a1, 10)) || ' ' || cnt;" ,
"set cnt = cnt + 1;" ,
"end" )
d = 'TST_sqlCall'
do qx= -2 to 3
call tstOut t, 'call' qx sqlCall(3,
, "call" prc "(call"qx"," qx", ' ')")
call tstOut t, 'resultSets' m.sql.3.resultSet.0,
'vars='m.sql.3.var.0 ,
'2='m.sql.3.var.2 '3='m.sql.3.var.3
if m.sql.3.resultSet \== '' then
do qy=1 until \ sqlNextResultSet(3)
call tstOut t, '* resultSet' qy m.sql.3.fetchFlds
m.d.length = ''
m.d.colType = ''
m.d.a1 = ''
m.d.a2 = ''
m.d.a3 = ''
do while sqlFetch(3, d)
call tstOut t, 'cur='m.d.cur 'name='m.d.name ,
'type='m.d.colType 'len='m.d.length ,
'a1='m.d.a1 'a2='m.d.a2 'a3='m.d.a3
end
call sqlClose 3
end
end
call tstOut t, 'rollback ' sqlUpdate(3, 'rollback')
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlCall
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: sqlCsmExe RZZ/DE0G
1 jRead .ab=abc, .ef=efg
2 jRead .AB=a, .CD=2 .EF=---, .GH=d
$/tstSqlCsm/ */
call pipeIni
call sqlCsmIni
call tst t, "tstSqlCsm"
call sqlConnect m.tst_csmRzDb
call jOpen sqlRdr('select * from sysdummy'), '<'
f1 = 'ab'
f2 = 'er'
r = jOpen(sqlRdr("select 'abc' , 'efg'",
'from sysibm.sysDummy1', f1 f2), '<')
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do while jRead(r)
dst = m.r
call out '1 jRead .ab='m.dst.f1', .ef='m.dst.f2
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
r = jOpen(sqlRdr(sql, 'AB CD EF GH'), '<')
do while jRead(r)
dst = m.r
call out '2 jRead .AB='m.dst.AB', .CD='m.dst.CD ,
'.EF='m.dst.EF', .GH='m.dst.GH
end
st = 'abc.Def.123'
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call sqlOIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csv4ObjRdr(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUPDATE-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN-+
--SPACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-R+
EORGSC-REORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-----+
----------
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REO+
RGSCANACCESS DRIVETYPE UPDATESIZE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASI+
ZE REORGHASHACCESS LPFACILITY LASTDATACHANGE
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTE+
RSENS HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call sqlOIni
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 12
call sqlFTabDef abc, 492, '%7e'
call sqlfTab abc, 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 12
call sqlFTabDef abc, 492, '%7e'
call ftabAdd abc, DBNAME, '%-8C', 'db', , 'allg vorher' ,
, 'allg nachher'
call ftabAdd abc, NAME , '%-8C', 'ts'
call ftabAdd abc, PARTITION , , 'part'
call ftabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc, 17
call fTabSetTit abc, ox, 2, 'others vorher'
call fTabSetTit abc, ox, 3, 'others nachher'
call sqlFTab abc, 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call sqlOIni
call tst t, 'tstSqlFTab2'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
call sqlQuery 15, sq1
call sqlFTab sqlfTabOpts(fTabReset(tstSqlFtab2, , , 'c')), 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlOIni
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 7, sq1
ft = sqlFTabOpts(fTabReset('tstSqFTab3', , ,'-a'))
call sqlFTab ft, 7
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t')
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabComplete f, 17, 1, 0
call fTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s49 into :M.SQL.49.D from :src
. e 6: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s49 into :M.SQL.49.D from :src
with into :M.SQL.49.D = M.SQL.49.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call sqlOIni
call tst t, 'tstSqlFTab4'
eOutOld = m.err_sayOut
m.err_sayOut = 1
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
m.err_sayOut = eOutOld
return
endProcedure tstSqlFTab4
tstSqlFTab5: procedure expose m.
/*
$=/tstSqlFTab5/
### start tst tstSqlFTab5 #########################################
-----D6-------D73------D62---------D92---
. 23456 -123.456 45.00 -123.45
-----D6-------D73------D62---------D92---
$/tstSqlFTab5/
*/
call pipeIni
call tst t, 'tstSqlFTab5'
call sqlConnect
sq1 = 'select dec(23456, 6) d6, dec(-123.4567, 7, 3) d73',
', dec(45, 6, 2) d62, dec(-123.45678, 9, 2) d92',
'from sysibm.sysDummy1'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab5), 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab5
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while in()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call out i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
call sqlOIni
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sys local ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: sqlCsmExe RZZ/DE0G
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: sqlCsmExe RZZ/DE0G
sys RZZ/DE0G csm ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/
$=/tstSqlCWsh/
### start tst tstSqlCWsh ##########################################
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -104: ILLEGAL+
. SYMBOL "?". SOME SYMBOLS THAT MIGHT
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
. e 8: sqlCode 0: rollback
. e 9: from RZZ Z24 DE0G
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.+
SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
. e 4: sqlCode 0: rollback
. e 5: from RZZ Z24 DE0G
sys RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCWsh/
*/
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_CsmRZ \== '') * 2
if tx = 1 then do
call tst t, "tstSqlCRx"
call sqlConnect
sys = 'local'
end
else if tx=2 then do
call tst t, "tstSqlCCsm"
call sqlCsmIni
sys = m.tst_csmRzDb 'csm'
call sqlConnect m.tst_csmRzDb, 'c'
end
else do
call tst t, "tstSqlCWsh"
call sqlWshIni
call sqlConnect m.tst_csmRzDb, 'w'
sys = m.tst_csmRzDb 'wsh'
end
cx = 9
call jOpen sqlRdr('select * from sysibm?sysDummy1'), '<'
call jOpen sqlRdr('select * from nonono.sysDummy1'), '<'
rr = jOpen(sqlRdr("select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"), '<')
do while jRead(rr)
dst = m.rr
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call jClose rr
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdateExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdateExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdateExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad' ,
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call pipeIni
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s49 into :M.SQL.49.D from :src
. e 3: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlOIni
call sqlConnect
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jRead(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call sqlOIni
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call pipeIni
call tst t, "tstSqlO1"
call sqlOIni
call sqlConnect
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jRead(qr)
call out m.qr
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call pipeIni
call tst t, "tstSqlO2"
call sqlOIni
call sqlConnect
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlSIni
call tst t, "tstSqlS1"
call sqlConnect
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWrite t, s1
call out 'select ... where 1=0'
call tstWrite t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlS1
tstSqlWsh: procedure expose m.
/*
$=/tstSqlWsh/
### start tst tstSqlWsh ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer>
1 rows fetched: select current server from sysibm.sysDummy1
tstR: @tstWriteoV16 isA :Sql*17
tstR: .ZWEI = second sel
tstR: .DREI = 3333
tstR: .VIER = 4444
1 rows fetched: select 'second sel' zwei, 3333 drei, 4444 vier from+
. sysibm....
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "XYZ". SOME SYM+
BOLS THAT
. MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAVEPOINT HO+
LD
. FREE ASSOCIATE
src xyz
. > <<<pos 1 of 3<<<
sql = xyz
sqlCode 0: rollback
from <csmRZ> <csmSys*> <csmDB>
$/tstSqlWsh/
*/
call pipeIni
call sqlWshIni
call tst t, "tstSqlWsh"
call tstTransCsm t
b = jBuf('select current server from' , 'sysibm.sysDummy1',
, ';;;', "select 'second sel' zwei, 3333 drei, 4444 vier" ,
, "from sysibm.sysDummy1",,";;xyz")
r = scanSqlStmtRdr(b)
call sqlWshOut r, m.tst_csmRzDb, 0, 'o'
call tstEnd t
return
endProcedure tstSqlWsh
tstSqlWs2: procedure expose m.
/*
$=/tstSqlWs2/
### start tst tstSqlWs2 ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 1
tstR: .NAME = NAME
tstR: @tstWriteoV16 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 2
tstR: .NAME = CREATOR
tstR: @tstWriteoV17 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 3
tstR: .NAME = TYPE
tstR: @tstWriteoV18 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 4
tstR: .NAME = DBNAME
$/tstSqlWs2/
*/
call pipeIni
call sqlWshIni
call tst t, "tstSqlWs2"
call tstTransCsm t
sql = "select current server, colNo, name" ,
"from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'",
"order by colNo fetch first 4 rows only"
w = oNew(m.class_SqlWshRdr, m.tst_csmRzDb, sql)
call pipeWriteNow w
call tstEnd t
return
endProcedure tstSqlWs2
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/
*/
call sqlSIni
call sqlConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call sqlSIni
call sqlConnect
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
### start tst tstDb2Ut ############################################
. TEMPLATE IDSN DSN(DSN.INPUT.UNL)
#jIn 1# template old ,
. template old ,
#jIn 2# LOAD DATA INDDN oldDD .
LOAD DATA LOG NO
. INDDN IDSN RESUME NO REPLACE COPYDDN(TCOPYD)
. DISCARDDN TDISC
. STATISTICS INDEX(ALL) UPDATE ALL
. DISCARDS 1
. ERRDDN TERRD
. MAPDDN TMAPD .
. WORKDDN (TSYUTD,TSOUTD) .
. SORTDEVT DISK .
#jIn 3# ( cols )
( cols )
$/tstDb2Ut/
*/
call pipeIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/*--- manualTest for csi --------------------------------------------*/
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, QZ01A1P,A006A)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, QZ01A1P,A006J, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tst wsh main and hooks ***************************************/
tstMain: procedure expose main
/*
$=/tstMain/
### start tst tstMain #############################################
DREI
. ABC
D ABC
3 abc
1 rows fetched: select 1+2 drei, 'abc' abc from sysibm.sysDummy1
$/tstMain/
*/
call pipeIni
i = jBuf("select 1+2 drei, 'abc' abc" ,
"from sysibm.sysDummy1")
call tst t, 'tstMain'
w = tstMain1
m.w.exitCC = 0
call wshRun w, 'sqlsOut */ a', i
call tstEnd t
return
endProcedure tstEnd
tstHookSqlRdr: procedure expose m.
/*
$=/tstHookSqlRdr/
### start tst tstHookSqlRdr #######################################
tstR: @tstWriteoV1 isA :Sql*2
tstR: .F5 = 5
tstR: .F2 = zwei
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: AT MICROSECONDS MICROSECOND SECONDS SECOND MINUT+
ES
. MINUTE HOURS
src select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
. > <<<pos 9 of 46<<<
sql = select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
from RZ4 S42 DP4G
fatal error in wsM: SQLCODE = -924: DB2 CONNECTION INTERNAL ERROR, +
00000002,
. 0000000C, 00F30006
sql = connect NODB
from RZ4 S42 NODB
$/tstHookSqlRdr/
*/
call pipeIni
call tst t, 'tstHookSqlRdr'
w = tst_wsh
m.w.outLen = 99
m.w.in = jBuf("select 2+3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
m.w.in = jBuf("select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
call wshHook_sqlRdr w, 'noDB'
call tstEnd t
return
endProcedure tstHookSqlRdr
/****** tstComp *******************************************************
test the wsh compiler
**********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompORu2
call tstCompORuRe
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompTable
call tstCompSyntax
if m.err_os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = wshCompRun(tstWWWW, spec, src)
noSyn = m.err.count = oldErr
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-{""""$v1} =" $-{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-¢2*3$! efg$-¢2*3$!hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-¢ 3 * 5 $! =" $-¢ 3 * 5 $!' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-¢4*5$! $-¢efg$-¢6*7$!"',
'abc$-¢4*5$! $-¢efg$-¢6*7$!$!',
, 'brackets $"$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!"',
'$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.-vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.-vv)="o2String($.-vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$.-vv',
, '$."s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.-vv= !vvDat
$.-¢"abc"$!=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.-vv=" $.-vv',
, '$"$.-¢""abc""$!="$.-¢"abc"$!'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.-vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.-vv)="o2string($.-vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPut 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@=¢ zwoelf dreiZ $! ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-¢ti$! z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPut 'vA', v1
call vPut 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@¢' stmt ,
, '$@with $vB ' stmt stmt '$!'
/*
$=/tstCompStmtArg/
### start tst tstCompStmtArg ######################################
compile :, 11 lines: v2 = var2
run without input
a1=eins a2=zwei, a3=elf b1= b2=
after op= v2=var2 var2=zwei,
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=- v2=var2 var2=ZWEI
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=. v2=var2 var2=ZWEI
$/tstCompStmtArg/
*/
call tstComp1 ': tstCompStmtArg',
, 'v2 = var2',
, '@% outArg eins zwei, elf',
, '$$ after op= v2=$v2 var2=$var2',
, '@% outArg - eins zwei, elf',
, '$$ after op=- v2=$v2 var2=$var2',
, '@% outArg . eins zwei, elf',
, '$$ after op=. v2=$v2 var2=$var2',
, 'proc $@:/outArg/' ,
, 'arg a1 {$v2} a3, b1 b2',
, '$$ a1=$a1 a2=${$v2} a3=$a3 b1=$b1 b2=$b2' ,
, '$/outArg/'
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
*** err: no method oRun in class String
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
*** err: no method oRun in class String
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $- ¢
. e 2: pos 3 in line 1: b $- ¢
*** err: no method oRun in class String
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .<$*( co1 $*) $$abc
. e 2: pos 3 in line 1: $@.<$*( co1 $*) $$abc
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
*** err: no method oRun in class String
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4old/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4old/
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= eins
. e 2: pos 1 in line 1: $= eins
*** err: no method oRun in class String
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= abc eins $$ = x
. e 2: pos 1 in line 1: $= abc eins $$ = x
*** err: no method oRun in class String
$/tstCompSynAss5/
$=/tstCompSynAss5old/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5old/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
*** err: no method oRun in class String
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
fatal error in wsM: compAst2rx bad ops=!) kind=M.0.KIND ast=0
*** err: bad ast 0
*** err: compAst2rx bad ops=!) kind=M.0.KIND ast=0
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
*/
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr var or namedBlock expected after proc
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% ¢roc p1$!
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition % ¢roc p1$!
. e 2: pos 3 in line 1: $@% ¢roc p1$!
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@% ¢roc p1$!
. e 2: pos 1 in line 1: $@% ¢roc p1$!
*** err: no method oRun in class String
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% ¢roc p1$!'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%¢call roc p1 !
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@%¢call roc p1 !
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%¢call roc p1 !'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^¢call( $** roc
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition )
. e 2: pos 13 in line 2: $*( p1 $*) )
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^¢call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call classIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!',
, '$$ out .$"$.-{o2}" $$.-¢ m.tstComp.2 $!',
, '$$ out .$"$.={o3}" $$.=¢ m.tstComp.3 $!',
, '$$ out .$"$.@{out o4}" $$.@@¢ call out m.tstComp.4 $!',
, '$$ out .$"$.@¢$$abc $$efg$!" $$. $.@@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$. $.@@¢ $$. m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$<.¢ m.tstComp.2 $!',
, '$$ out .$"$.<{o3}" $$<=¢ m.tstComp.3 $!',
, '$$ out .$"$.<@{out o4}" $$<@¢ call out m.tstComp.4 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o1, o2!$; $@.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%¢oRun$!' ,
, ' $@%¢oRun $"-{1 arg only}" oder?$!' ,
, ' $@%¢oRun - $.".{1 obj only}" ''oder?''$! $=v2=zwei' ,
, ' $@%¢oRun - $"{2 args}", "und" $v2"?"$!' ,
, ' $@%¢oRun - $"{3 args}", $v2, "und drei?"$!'
return
endProcedure tstCompORun
tstCompORu2: procedure expose m.
/*
$=/tstCompORu2/
### start tst tstCompORu2 #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
$/tstCompORu2/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORu2',
, '$@oRun', '$@%oRun',
, '$@% oRun eins, zwei, drei' ,
, '$@%¢ oRun eins, zwei, drei $!',
, '$@% oRun - "-eins", "zwei", drei' ,
, '$@%¢ oRun - "-eins", "zwei", drei $!'
return
endProcedure tstCompORu2
tstCompORuRe: procedure expose m.
/*
$=/tstCompORuRe/
### start tst tstCompORuRe ########################################
compile @, 9 lines: $$ primary $-^oRuRe eins, zwei
run without input
primary oRuRe(arg=1, v2=, v3=) eins, zwei
oRuRe(arg=2, v2=expr, zwei, v3=)
oRuRe(arg=3, v2=-expr, v3=zwei)
oRuRe(arg=2, v2=block, zwei, v3=)
oRuRe(arg=3, v2=-block, v3=zwei)
$/tstCompORuRe/ */
call compIni
call vPut 'oRuRe', oRunner('parse arg , v2, v3;',
'return "oRuRe(arg="arg()", v2="v2", v3="v3")"' )
call tstComp1 '@ tstCompORuRe',
, '$$ primary $-^oRuRe eins, zwei' ,
, '$$-^ oRuRe expr, zwei',
, '$$-^ oRuRe - "-expr", "zwei"',
, '$$-^¢oRuRe block, zwei$!' ,
, '$$-^¢',, 'oRuRe - "-block", "zwei"' , , '$!'
return
endProcedure tstCompORuRe
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=¢$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=¢$dsn $*+',
, tstFB('::f', 0) '$!',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($.-vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $!
@@@file from 3 line @ block
$@<@¢ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty ¢ block
$@<¢ $!
{{{ empty ¢ block with comment
$@<¢ $*+ abc
$!
{{{ one line ¢ block
$@<¢ the only $"¢...$!" line $*+.
$vv $!
{{{ one line -¢ block
$@<-¢ the only $"-¢...$!" "line" $vv $!
{{{ empty #¢ block
$@<#¢
$!
{{{ one line #¢ block
$@<#¢ the only $"-¢...$!" "line" $vv $¢vv${x}$!
$!
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty ¢ block
{{{ empty ¢ block with comment
{{{ one line ¢ block
. the only ¢...$! line value-of-vv .
{{{ one line -¢ block
THE ONLY -¢...$! line value-of-vv
{{{ empty #¢ block
{{{ one line #¢ block
. the only $"-¢...$!" "line" $vv $¢vv${x}$!
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=. $.<.¢s2o("f2 line 1" o2String($.-vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@<-dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<¢ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<¢ zeile eins ' ,
, ' zeile zwei $!' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@¢
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@¢' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $!',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@¢ $@for vv $$ <$vv> $! .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> +
<zwanzig 21 22 23 24 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz a+
b<zwanzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@¢ $@for vv $$ <$vv> $! ',
, ' $$ output eins $-=¢$@.eins$! $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>-= $-¢ $dsn $! 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=¢$@<$-dsn$!'
/*
$=/tstCompRedi2/
### start tst tstCompRedi2 ########################################
compile @, 12 lines: call mAdd t.trans, $var "dsnTestRedi"
run without input
>1<dsnTestRedi currTimeRedi
>2<$"dsnTestRedi" currTimeRedi
>3<$"dsnTestRedi" ::v currTimeRedi
>4<$-var" currTimeRedi
>5<$dsnTestRedi" currTimeRedi
$/tstCompRedi2/
*/
call vPut 'var', tstFileName('compRedi', 'r')
call vPut 'tst', translate(date()'+'time()'+testRedi2', '_', ' ')
call tstComp1 '@ tstCompRedi2 ' ,
, 'call mAdd t.trans, $var "dsnTestRedi"',
, 'call mAdd t.trans, $tst "currTimeRedi"',
, '$<> $>'vGet('var') '::v $$ $">1<'vGet('var')'" $tst',
, '$<> $<'vGet('var') ' $@ call pipeWriteAll' ,
, '$<> $>$"'vGet('var')' ::v" $$ $">2<$""'vGet('var')'""" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>$"'vGet('var')'" ::v $$ $">3<$""'vGet('var')'"" ::v" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>-var $$ $">4<$"-var" $tst',
, '$<> $<-var $@ call pipeWriteAll',
, '$<> $>$var ::v $$ $">5<$"$var" $tst',
, '$<> $<$var $@ call pipeWriteAll'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc;" ,
"$@for v $$ compRun $v$cc" ,
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^¢compile = +
=$! $<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^¢compile = =$! $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$.-v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-¢
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $!
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '$=/vD/valueVonD' ,
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@¢ $$ vF=$vF$!' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:¢ix=- $ix+1',
, ' $$ for $ix -> $v' ,
, '! | @¢call pipePreSuf "<<",">>"',
, '$! @%¢p1 total $ix im argumentchen$!',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:¢tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '! $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompTable: procedure expose m.
/*
$=/tstCompTable1/
### start tst tstCompTable1 #######################################
compile :, 6 lines: table $*( sdf $*) .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = v1
tstR: .fZwei = valueZwei undD
tstR: .fDrei = rei
zweite
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = w1 wZwe
tstR: .fZwei = i
tstR: .fDrei = wwwDrei
$/tstCompTable1/
*/
call wshIni
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
c2 = classNew('n* CompTable u f fEins v, f fDrei v')
call tstComp1 ': tstCompTable1',
, 'table $*( sdf $*) ' ,
, 'fEins fZwei $*(....$*) fDrei ' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"$!',
, ' v1 valueZwei undDrei ' ,
, '$$ zweite',
, ' w1 wZwei wwwDrei '
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV5 isA :<TstCT2Class>
tstR: .fEins = withValue fEinsC
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call tstComp1 ': tstCompWithNew',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢ fDrei = withNewValuel drei $! $! ' ,
, 'withNew ' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, 'withNew fEins = withValue fEinsC' ,
, '$@¢call mAdd t.trans, className("'c2'") "<TstCT2Class>"',
, '$@¢$=fDrei = withValue fDreiC$! $! '
/*
$=/tstCompWithNeRe/
### start tst tstCompWithNeRe #####################################
compile :, 11 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstClassR2>
tstR: .rA = value rA
tstR: .rB refTo @!value rB isA :w
tstR: @tstWriteoV4 isA :<TstClassR2>
tstR: .rA = val33 rA
tstR: .rB refTo @!VAL33 RB isA :w
tstR: @tstWriteoV5 isA :<TstClassR2>
tstR: .rA = val22 rA
tstR: .rB refTo @!VAL22 RB isA :w
tstR: @tstWriteoV6 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
vOth=value vOth fZwei=fZwei Wert vorher ?fDrei=0
$/tstCompWithNeRe/
*/
cR = classNew("n* CompTable u f rA v, f rB r")
call vRemove 'fDrei'
call vPut 'fZwei', 'fZwei Wert vorher'
call tstComp1 ': tstCompWithNeRe',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, '@:¢withNew rA =value rA $=rB=. "!value rB" ' ,
, '$@ call mAdd t.trans, className("'cR'") "<TstClassR2>"$!',
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢withNew rA =val22 rA $=rB=. !val22 rB ' ,
, '{vOth} = value vOth',
, '$@:¢withNew rA =val33 rA $=rB=. !val33 rB $! $!' ,
, '$@:¢ fDrei = withNewValuel drei $! $! ',
, '$<> $$ vOth=$vOth fZwei=$fZwei ?fDrei=${?fDrei}'
return
endProcedure tstCompTable
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| call sql2tab , , sqlFTabOpts(fTabReset(tstCompS1, '1', '1', '-'))
$<>
$= s1 = select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
call sqlQuery 7, $s1
t2 = sqlFTabOpts(fTabReset(tstCompS2, '2 1', '2 c', '-'))
ox = m.t2.0 + 1
call sqlFTabOthers t2, 7
call sqlFTab fTabSetTit(t2, ox, 2, '-----'), 7
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 12 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
*/
call sqlSIni
call sqlConnect
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
/* ?????rework tstTut ?????????????????*/
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-¢sysvar(sysnode) date() time()?!ts=$ts 10*len=$-¢length($ts)*10$!
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-¢sysvar(sysnode) date() time()?!ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$@:¢table
db ts
DGDB9998 A976
DA540769 A977
$!
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:¢withNew out :¢
db = DGDB9998
ts =<:¢table
ts
A976
A977
$!
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:¢table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err_os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase ********************************************************
test the basic classes
**********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call classIni
call tstF
call tstFWords
call tstFtst
call tstFCat
call tstOEins
call tstO2Text
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstfUnits
call tstCsv
call tstCsv2
call tstCsvExt
call tstCsvInt
call tstCsvV2F
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ---------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do forever
i = mIter(i)
if i == '' then
leave
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstFCat: procedure expose m.
/*
$=/tstFCat/
### start tst tstFCat #############################################
fCat( ,0) =;
fCat(1 ,0) =;
fCat(112222 ,0) =;
fCat(3%#a1%c2 ,0) =;
fCat(4%#a1%c2@%c333 ,0) =;
fCat(5%#a1%c2@%c3@%c4 ,0) =;
fCat( ,1) =eins;
fCat(1 ,1) =eins;
fCat(112222 ,1) =eins;
fCat(3%#a1%c2 ,1) =1eins2;
fCat(4%#a1%c2@%c333 ,1) =1eins2eins333;
fCat(5%#a1%c2@%c3@%c4 ,1) =1eins2eins3eins4;
fCat( ,2) =einszwei;
fCat(1 ,2) =eins1zwei;
fCat(112222 ,2) =eins112222zwei;
fCat(3%#a1%c2 ,2) =1eins231zwei2;
fCat(4%#a1%c2@%c333 ,2) =1eins2eins33341zwei2zwei333;
fCat(5%#a1%c2@%c3@%c4 ,2) =1eins2eins3eins451zwei2zwei3zwei4;
fCat( ,3) =einszweidrei;
fCat(1 ,3) =eins1zwei1drei;
fCat(112222 ,3) =eins112222zwei112222drei;
fCat(3%#a1%c2 ,3) =1eins231zwei231drei2;
fCat(4%#a1%c2@%c333 ,3) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
fCat(5%#a1%c2@%c3@%c4 ,3) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstFCat/ */
call pipeIni
call tst t, "tstFCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstFCat1 qx
call tstFCat1 qx, '1'
call tstFCat1 qx, '112222'
call tstFCat1 qx, '3%#a1%c2'
call tstFCat1 qx, '4%#a1%c2@%c333'
call tstFCat1 qx, '5%#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstFCat
tstFCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("fCat("fmt, 26)","m.qq.0") ="fCat(fmt, qq)";"
return
endProcedure tstFCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.8 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.3 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = o2StrZYX
. .MET = return m.m
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.11 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.10 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.9 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .3 refTo @CLASS.12 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .4 refTo @CLASS.14 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.13 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.15 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .6 refTo @CLASS.16 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.13 done :class @CLASS.13
. .7 refTo @CLASS.19 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.18 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .8 refTo @CLASS.21 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.20 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.8 done :class @CLASS.8
$/tstClass2/
*/
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
t1 4 fldD .FV, .FR
clear q1 FV= FR= FW= FO=
orig R1 FV=valFV FR=refFR FW=!valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=!valFW FO=obj.FO
t2 2 fldD .EINS.ZWEI, .
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 fldD M.<class tst...Tf33>.FLDD.1, M.<class tst...Tf33>.FLDD.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call classIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w, f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = '!valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFldD(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'fldD' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.7
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.7
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
else /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class <class_S>
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new m = mNew('<class T..1>'); call oMutate m, '<class T..1>'; ca+
ll classClear '<class T..1>', m;
$/tstO/
*/
call mIni
call tst t, 'tstO'
call classIni
call mAdd t.trans, m.class_s '<class_S>'
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1)
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1)
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstO2Text: procedure expose m.
/*
$=/o2Text/
### start tst o2Text ##############################################
. > .
und _s abc > und so
und _s lang > und so und so und so und so und so und so und so und+
. so und so ....
!und _w abc > und so
o1 > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZwei fDrei=v_o+
1_fDrei!
o1 lang > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZweiv_o1_fZwei+
v_o1_fZwei...!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = 'tstO2T1'
call oMutate o1, cl
call mPut o1'.fEins', 'v_o1_fEins'
call mPut o1'.fZwei', 'v_o1_fZwei'
call mPut o1'.fDrei', 'v_o1_fDrei'
call tst t, 'o2Text'
maxL = 66
call tstOut t, ' >' o2Text(' ', maxL)
call tstOut t, 'und _s abc >' o2Text('und so ', maxL)
call tstOut t, 'und _s lang >' o2Text(copies('und so ',33), maxL)
call tstOut t, '!und _w abc >' o2Text('und so ', maxL)
call tstOut t, 'o1 >' o2Text(o1 , maxL)
call mPut o1'.fZwei', copies('v_o1_fZwei',33)
call tstOut t, 'o1 lang >' o2Text(o1 , maxL)
f = file('abc.efg')
r = oRunner('say o2Text test')
call mAdd t.trans, r '<tstRunObj>',
, className(objClass(r)) '<tstRunCla>' ,
, f '<tstFileObj>'
call tstOut t, 'runner >' o2Text(r , maxL)
call tstOut t, 'file >' o2Text(f , maxL)
call mAdd t.trans, r '<tstRunnerObj>',
, className(objClass(r)) '<tstRunnerCla>'
call tstEnd t
return
endProcedure tstO2Text
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>) but not open+
ed w
*** err: can only write JSay#jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>) but not op+
ened w
*** err: JRWEof#open(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>) but not opened w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd b'.BUF', 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWrite b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen jClose(c), m.j.cRead
do while jRead(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call out ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Affff', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call pipeIni
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 'sss',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get TST.ADR1
v2 hasKey 0
one to theBur
two to theBuf
v1=TST.ADR1 o=TST.ADR1
v3=v3WieGehts? o=v3WieGehts?
v4=!v4WieGehts? o=!v4WieGehts?
o o0=<o0>
s o0=<o0>
o o0=<o0>
s o0=<o0>
o0&fSt0=rexx o0.fSt0 o=rexx o0.fSt0
o0&fRe0=!rexx o0.fRe0 o=!rexx o0.fRe0
o0&=rexx o0-value o=rexx o0-value
o o0=<o0>
s o0=<o0>
o0&fSt0=put o0.fSt0 o=put o0.fSt0
o0&fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o0&=put o0-value o=put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
o o1=<o1> s o1=<o1>
o1&fStr=put-o1.fStr o=put-o1.fStr
o1&=put-o1-value o=put-o1-value
o1&fRef=<o0> o=<o0>
o1&fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o1&fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= !put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o1&fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef>fStr=put-o1.fStr o=put-o1.fStr
o2&fRef>=put-o1-value o=put-o1-value
o2&fRef>fRef=<o0> o=<o0>
o2&fRef>fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o2&fRef>fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o2&fRef>fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o2&fRef>fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=!<put oS.fStR.2>
oS&fStR.0=2 .1=!<put oS.fStR.1> .2=!<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
*** err: undefined var oS&12
oS&0=9876 .12=M. .1234=<put oS.1234>
$/tstEnvVarsS/
$=/tstEnvVars3/
### start tst tstEnvVars3 #########################################
m.<o0>=*o0*val vGet(<o0>>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(<o0>>fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(<o0>>fRe0)=<o1>
m.<o1>=*o1*val vGet(<o0>>fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(<o0>>fRe0>fStr)=*o1.fStr*val
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0)=<o0>
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0&)=<o0>
m.<o0>=*o0*val vGet(tstEnvVar0&>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(tstEnvVar0&fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(tstEnvVar0&fRe0)=<o1>
m.<o1>=*o1*val vGet(tstEnvVar0&fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(tstEnvVar0&fRe0>fStr)=*o1.fStr*val
m.<o1>.fVar=tstEnvVar2 vGet(tstEnvVar0&fRe0>fVar)=tstEnvVar2
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&)=<o2>
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&>)=*o2*val
m.<o2>.fStr=*o2.fStr*val vGet(tstEnvVar0&fRe0>fVar&fStr)=*o2.fStr*v+
al
m.<o0>=*o0*put2 vGet(<o0>>)=*o0*put2
m.<o0>.fSt0=*o0.fSt0*put2 vGet(<o0>>fSt0)=*o0.fSt0*put2
m.<o1>=*o0>fRe0>put2 vGet(<o0>>fRe0>)=*o0>fRe0>put2
m.<o1>.fStr=*o0>fRe0>fStr*put2 vGet(<o0>>fRe0>fStr)=*o0>fRe0>fStr*p+
ut2
m.<o0>=*v0&>*put3 vGet(tstEnvVar0&>)=*v0&>*put3
m.<o0>.fSt0=*v0&fSt0*put3 vGet(tstEnvVar0&fSt0)=*v0&fSt0*put3
m.<o1>=*v0&fRe0>*put3 vGet(tstEnvVar0&fRe0>)=*v0&fRe0>*put3
m.<o1>.fStr=*v0&fRe0>fStr*put3 vGet(tstEnvVar0&fRe0>fStr)=*v0&fRe0>+
fStr*put3
m.<o2>=*v0&fRe0>fVar&>*put3 vGet(tstEnvVar0&fRe0>fVar&>)=*v0&fRe0>f+
Var&>*put3
m.<o2>.fStr=*v0&fRe0>fVar&fStr*put3 vGet(tstEnvVar0&fRe0>fVar&fStr)+
=*v0&fRe0>fVar&fStr*put3
$/tstEnvVars3/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v, f fVar v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars3"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
fSt0 = 'fSt0'
fRe0 = 'fRe0'
fStr = 'fStr'
fRef = 'fRef'
fVar = 'fVar'
v0 = 'tstEnvVar0'
v2 = 'tstEnvVar2'
m.o0 = '*o0*val'
m.o0.fSt0 = '*o0.fSt0*val'
m.o0.fRe0 = o1
m.o1 = '*o1*val'
m.o1.fStr = '*o1.fStr*val'
m.o1.fRef = o2
m.o1.fVar = v2
m.o2 = '*o2*val'
m.o2.fStr = '*o2.fStr*val'
m.v.v0 = o0
m.v.v2 = o2
call tstEnvVarsMG o0, o0'>'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call tstEnvVarsMG o0'.'fRe0, o0'>'fRe0
call tstEnvVarsMG o1, o0'>'fRe0'>'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call tstEnvVarsMG v'.'v0, v0
call tstEnvVarsMG v'.'v0, v0'&'
call tstEnvVarsMG o0, v0'&>'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call tstEnvVarsMG o0'.'fRe0, v0'&'fRe0
call tstEnvVarsMG o1, v0'&'fRe0'>'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call tstEnvVarsMG o1'.'fVar, v0'&'fRe0'>'fVar
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call vPut o0'>', '*o0*put2'
call tstEnvVarsMG o0, o0'>'
call vPut o0'>'fSt0, '*o0.fSt0*put2'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call vPut o0'>'fRe0'>', '*o0>fRe0>put2'
call tstEnvVarsMG o1, o0'>'fRe0'>'
call vPut o0'>'fRe0'>'fStr, '*o0>fRe0>fStr*put2'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call vPut v0'&>', '*v0&>*put3'
call tstEnvVarsMG o0, v0'&>'
call vPut v0'&'fSt0, '*v0&fSt0*put3'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call vPut v0'&'fRe0'>', '*v0&fRe0>*put3'
call tstEnvVarsMG o1, v0'&'fRe0'>'
call vPut v0'&'fRe0'>'fStr, '*v0&fRe0>fStr*put3'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call vPut v0'&'fRe0'>'fVar'&>', '*v0&fRe0>fVar&>*put3'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call vPut v0'&'fRe0'>'fVar'&fStr', '*v0&fRe0>fVar&fStr*put3'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call tstEnd t, "tstEnvVars"
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPut('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPut 'theBuf', jBuf()
call pipe '+F' , vGet('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGet('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGet('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGet('v3')
call vPut 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGet('v4')
call vPut 'o0', o0
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call vPut 'o0&>', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPut 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o1', o1
call vPut 'o1&>', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPut 'o1&fRef', vGet('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGet('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGet('o1&fStr')
call tstOut t, 'o1&='vGet('o1&>') 'o='vGet('o1&>')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGet('o1&fRef')
call tstOut t, 'o1&fRef>fSt0='vGet('o1&fRef>fSt0') ,
'o='vGet('o1&fRef>fSt0')
call tstOut t, 'o1&fRef>fRe0='vGet('o1&fRef>fRe0'),
'o='vGet('o1&fRef>fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPut 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGet('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o2', o2
call vPut 'o2&fRef', vGet('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGet('o2'),
'getO(o2&fRef)='vGet('o2&fRef')
call tstOut t, 'o2&fRef>fStr='vGet('o2&fRef>fStr'),
'o='vGet('o2&fRef>fStr')
call tstOut t, 'o2&fRef>='vGet('o2&fRef>'),
'o='vGet('o2&fRef>')
call tstOut t, 'o2&fRef>fRef='vGet('o2&fRef>fRef') ,
'o='vGet('o2&fRef>fRef')
call tstOut t, 'o2&fRef>fRef>fSt0='vGet('o2&fRef>fRef>fSt0') ,
'o='vGet('o2&fRef>fRef>fSt0')
call tstOut t, 'o2&fRef>fRef>fRe0='vGet('o2&fRef>fRef>fRe0'),
'o='vGet('o2&fRef>fRef>fRe0')
call tstOut t, 'o2&fRef>fNest.fSt0='vGet('o2&fRef>fNest.fSt0'),
'o='vGet('o2&fRef>fNest.fSt0')
call tstOut t, 'o2&fRef>fNest&fRe0='vGet('o2&fRef>fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPut 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGet('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstEnvVarsMG: procedure expose m.
parse arg m, g
call tstOut t, 'm.'m'='m.m 'vGet('g')='vGet(g)
return
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& !get1 w
tstK1&f1 get1.f1 v
tstK1&f2 !get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI !get1.f3.fZwei w
tstK1&F3.FDREI o !get1.f3.fDrei w
tstK1&F3.FDREI !get1.f3.fDrei w
tstK1&F3.1 !get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2>F1 get1.f1 v
tstK1&F3.2>F3.2>F2 !get1.f2 w
*** err: undefined var F1
F1 M..
F1 get1.f1 v
f2 !get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI !get1.f3.fZwei w
F3.FDREI o !get1.f3.fDrei w
F3.1 !get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined var F1
po-1 F1 M..
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it*/
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it*/
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPut 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGet('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&>')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGet('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2>F1 ' vGet('tstK1&F3.2>F1')
call tstOut t, 'tstK1&F3.2>F3.2>F2' ,
vGet('tstK1&F3.2>F3.2>F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGet('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: null address at &FEINS in c3&F1&FEINS
*** err: undefined var c3&F1&FEINS
. s c3&F1&FEINS = M..
*** err: null address at &FEINS in c3&F3&FEINS
*** err: null address at &FEINS in c3&F3&FEINS
*** err: undefined var c3&F3&FEINS
. s c3&F3&FEINS = M..
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: undefined var c3&FEINS
. s c3&FEINS = M..
getO c3&
aft Put s c3&>FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: undefined var F1
popW c3 s F1 = M..
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPut 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGet('c3&')
call vPut 'c3&>', oNew('TstEW0')
call vPut 'c3&>FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&>FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n? TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n? TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr"; mr = m.m.rdr;' ,
'm.rStem.0 = jRead(mr); m.rStem.1 = m.mr',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWrite b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWrite b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsn: procedure expose m.
/*
$=/tstDsn/
### start tst tstDsn ##############################################
aa has 4 members: created
- aa(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- aa(EINS) 1 lines, aa(eins) 1/1
- aa(NULL) 0 lines
- aa(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 1 members: copy eins, eins1
- bb(EINS1) 1 lines, aa(eins) 1/1
bb has 2 members: copy zwei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
cc has 1 members: copy drei cc new
- cc(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
bb has 5 members: copy
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 8 members: copy null eins drei >*4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(NULL4) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 7 members: delete null4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete eins4 drei4 eins drei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete drei4
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
before seqFuenf 5 lines, seqFuenf ::f 1/5, seqFuenf ::f 2/5, seqFue+
nf ::f 3/5, seqFuenf ::f 4/5, seqFuenf ::f 5/5
copy zwei seqFuenf 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
copy null seqFuenf 0 lines
before seqVier 4 lines, seqVier ::f 1/4, seqVier ::f 2/4, seqVier :+
:f 3/4, seqVier ::f 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier ::f 1/4, seqVier ::f 2/4, seqVier ::+
f 3/4, seqVier ::f 4/4
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
delete seqFuenf does not exist
delete seqFuenf does not exist
$/tstDsn/
*/
do sx=0 to m.tst_csmRZ \== ''
sys = copies(m.tst_csmRz'/', sx)
say 'csm/sys='sys '+++++++++++++++++++++++++++'
call tst t, 'tstDsn'
pr = tstFileName(sys'tstDsn', 'r')
call tstDsnWr pr'.aa(null) ::f', 0
call tstDsnWr pr'.aa(eins)', 1
call tstDsnWr pr'.aa(zwei)', 2
call tstDsnWr pr'.aa(drei)', 3
call tstDsnWr pr'.seqVier ::f', 4
call tstDsnWr pr'.seqFuenf ::f', 5
call tstDsnRL t, pr'.aa', 'created'
call dsnCopy pr'.aa(eins)', pr'.bb(eins1)'
call tstDsnRL t, pr'.bb', 'copy eins, eins1'
call dsnCopy pr'.aa(zwei)', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy zwei'
call dsnCopy pr'.aa(drei)', pr'.cc'
call tstDsnRL t, pr'.cc', 'copy drei cc new'
call dsnCopy pr'.aa', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy'
call dsnCopy pr'.aa', pr'.bb', 'null>null4 eins>eins4' ,
'drei>drei4'
call tstDsnRL t, pr'.bb', 'copy null eins drei >*4'
call dsnDel pr'.bb(null4)'
call tstDsnRL t, pr'.bb', 'delete null4'
call dsnDel pr'.bb(eins)'
call dsnDel pr'.bb(eins4)'
call dsnDel pr'.bb', 'drei drei4'
call tstDsnRL t, pr'.bb', 'delete eins4 drei4 eins drei'
call dsnDel pr'.bb(drei4)'
call tstDsnRL t, pr'.bb', 'delete drei4'
call tstOut t, 'before' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(zwei)', pr'.seqFuenf'
call tstOut t, 'copy zwei' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(null)', pr'.seqFuenf'
call tstOut t, 'copy null' tstDsnr1(pr'.seqFuenf')
call tstOut t, 'before' tstDsnr1(pr'.seqVier')
call dsnCopy pr'.seqVier', pr'.bb(froVier)'
call tstDsnRL t, pr'.bb', 'copy .seqVier'
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
/* delete all to avoid mixup in next loop */
pr = tstFileName(sys'tstDsn', 'r')
call tstEnd t
end
return
endProcedure tstDsn
tstDsnWr: procedure expose m.
parse arg dsn, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn, o., li, 1
return
endProcedure tstDsnWr
tstDsnR1: procedure expose m.
parse arg dsn
q = strip(substr(dsn, lastPos('.', dsn) + 1))
if \ dsnExists(dsn) then
return q 'does not exist'
call readDsn dsn, i.
r = q i.0 'lines'
do ix=1 to i.0
r = r',' strip(i.ix)
end
return r
endProcedure tstDsnR1
tstDsnRL: procedure expose m.
parse arg t, dsn, msg
q = strip(substr(dsn, lastPos('.', dsn) + 1))
call mbrList tst_dsnL, dsn
call tstOut t, q 'has' m.tst_dsnL.0 'members:' msg
do mx=1 to m.tst_dsnL.0
call tstOut t, '-' tstDsnR1(dsn'('m.tst_dsnL.mx')')
end
return
endProcedure tstDsnRL
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(RZZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(RZZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(RZZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(RZZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(RZZ/A540769.WK.rxxYY(nonon)) 0
*** err: error in csm mbrList ?QZ/A540769.WK.RXXYY(NONON) .
. e 1: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 2: CSMSI77E SYSTEM=?QZ
dsnExists(?qZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
rz = m.tst_csmRZ
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists('rz'/'d1')' dsnExists(rz'/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(?qZ/'d1')' dsnExists('?qZ/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+ffffff', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err_os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err_os = 'TSO' then
return pds'('mbr') ::F'
if m.err_os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err_os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir dsnList 0
empty dir fileList
filled dir .* dsnList 3
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir fileList
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir dsnList 6
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
filled dir fileList recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err_os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstFileListDsn t, filePath(fi), 'empty dir'
call tstOut t, 'empty dir fileList'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstFileListDsn t, filePath(fi)'.*', 'filled dir .*'
call tstOut t, 'filled dir fileList'
call jWriteNow t, fl
call tstFileListDsn t, filePath(fi), 'filled dir'
call tstOut t, 'filled dir fileList recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListDsn: procedure expose m.
parse arg t, fi, msg
call tstOut t, msg 'dsnList' dsnList(tst_FileListDsn, fi)
do ox=1 to m.tst_FileListDsn.0
call tstOut t, m.tst_FileListDsn.ox
end
return
endProcedure tstFileListDsn
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
/*--- manualTest time -----------------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
/*--- manualTest Mail -----------------------------------------------*/
tstMail: procedure expose m.
do i=1 to 2
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mailText xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, '<ol><li>'left('und eine lange', 200, '+')203 '</li>',
, '<li bgcolor=yellow>und kurz</li></ol>' ,
, '<h1>und Schluss mit html</h1>'
call mailSend xy
call sleep 3
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call tstOut t, "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call tstOut t, 'tstF2' fmt '-----'
do vx=1 to words(vals)
call tstOut t, f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, %#e-- --
%#a%9c .
*%#a%-7c .
??empty?? eins
1space eins
, %#e-- eins
%#a%9c eins
*%#a%-7c eins .
??empty?? einszwei
1space eins zwei
, %#e-- eins, zwei
%#a%9c eins zwei
*%#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, %#e-- eins, zwei, drei
%#a%9c eins zwei drei
*%#a%-7c eins *zwei *drei .
$/tstFWords/
*/
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', %#e-- ' fWords(', %#e--' ,subword(ws,1,l))
call tstOut t, '%#a%9c ' fWords('%#a%9c' ,subword(ws,1,l))
call tstOut t, '*%#a%-7c ' fWords('*%#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SY => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
1956-01-29-23.34.56.987654 Sj => 56029|
1956-01-29-23.34.56.987654 SJ => 714076|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sY => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$/tstFTsts/
Winterzeit
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
Sommerzeit
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DY => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 Dj => 45169|
23450618 DJ => 856296|
$/tstFTstD/
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dY => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dj => 12206|
120724 dJ => 734707|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EY => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.2467 eS => 2024-05-31-00.00.00.000000|
31.05.2467 es => 2024-05-31-00.00.00|
31.05.2467 e => 2024-05-31-00.00.00|
31.05.2467 eD => 20240531|
31.05.2467 ed => 240531|
31.05.2467 eE => 31.05.2024|
31.05.2467 ee => 31.05.2467|
31.05.2467 et => 00.00.00|
31.05.2467 eT => 00:00:00.000000|
31.05.2467 eY => OF31|
31.05.2467 eM => F3100000|
31.05.2467 eH => A00000|
31.05.2467 ej => 24152|
31.05.2467 eJ => 739036|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0001-01-01-12.34.56.000000|
12.34.56 ts => 0001-01-01-12.34.56|
12.34.56 t => 0001-01-01-12.34.56|
12.34.56 tD => 00010101|
12.34.56 td => 010101|
12.34.56 tE => 01.01.0001|
12.34.56 te => 01.01.01|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tY => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tj => 01001|
12.34.56 tJ => 0|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0001-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0001-01-01-23.45.06|
23.45.06.784019 T => 0001-01-01-23.45.06|
23.45.06.784019 TD => 00010101|
23.45.06.784019 Td => 010101|
23.45.06.784019 TE => 01.01.0001|
23.45.06.784019 Te => 01.01.01|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TY => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstY/
### start tst tstFTstY ############################################
FE25 YS => 2015-04-25-00.00.00.000000|
FE25 Ys => 2015-04-25-00.00.00|
FE25 Y => 2015-04-25-00.00.00|
FE25 YD => 20150425|
FE25 Yd => 150425|
FE25 YE => 25.04.2015|
FE25 Ye => 25.04.15|
FE25 Yt => 00.00.00|
FE25 YT => 00:00:00.000000|
FE25 YY => FE25|
FE25 YM => E2500000|
FE25 YH => A00000|
FE25 Yj => 15115|
FE25 YJ => 735712|
$/tstFTstY/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0001-08-23-17.49.50.000000|
I2317495 Ms => 0001-08-23-17.49.50|
I2317495 M => 0001-08-23-17.49.50|
I2317495 MD => 00010823|
I2317495 Md => 010823|
I2317495 ME => 23.08.0001|
I2317495 Me => 23.08.01|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MY => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 Mj => 01235|
I2317495 MJ => 234|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0001-01-01-12.34.56.000000|
B23456 Hs => 0001-01-01-12.34.56|
B23456 H => 0001-01-01-12.34.56|
B23456 HD => 00010101|
B23456 Hd => 010101|
B23456 HE => 01.01.0001|
B23456 He => 01.01.01|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HY => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 Hj => 01001|
B23456 HJ => 0|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nY => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nj => 56114|
19560423 17:58:29 nJ => 714161|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32101230 10:21:32.456789 NS => 3210-12-30-10.21.32.456789|
32101230 10:21:32.456789 Ns => 3210-12-30-10.21.32|
32101230 10:21:32.456789 N => 3210-12-30-10.21.32|
32101230 10:21:32.456789 ND => 32101230|
32101230 10:21:32.456789 Nd => 101230|
32101230 10:21:32.456789 NE => 30.12.3210|
32101230 10:21:32.456789 Ne => 30.12.10|
32101230 10:21:32.456789 Nt => 10.21.32|
32101230 10:21:32.456789 NT => 10:21:32.456789|
32101230 10:21:32.456789 NY => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
*/
say "f('%t ')" f('%t ')
call timeIni
allOut = 'Ss DdEetTYMHjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.2467' ,
't12.34.56' ,
'T23.45.06.784019' ,
'YFE25' ,
'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
if ix=2 then do
call tstOut t, left(iV, 30) iF'u' '+>' f('%t'iF'u', iV)'|'
call tstOut t, left(iV, 30) iF'L' '+>' f('%t'iF'L', iV)'|'
end
call tstEnd t
end
return
endProcedure tstFTst
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
cc = fTabAdd(abc, , , 'c3L')
m.cc.fmt = fTabDetectFmt(st)
call fTabAdd abc, 'a2i', '% 8E'
cc = fTabAdd(abc, 'b3b', ,'drei')
m.cc.fmt = fTabDetectFmt(st, '.b3b')
call fTabAdd abc, 'd4', '%-7C'
cc = fTabAdd(abc, 'fl5')
m.cc.fmt = fTabDetectFmt(st, '.fl5')
cc = fTabAdd(abc, 'ex6')
m.cc.fmt = fTabDetectFmt(st, '.ex6')
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call pipeIni
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAdd ft, '' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAdd ft, 'a2i' , '%6i'
call fTabAdd ft, 'b3b' , '%-12C'
call fTabAdd ft, 'd4' , '%10C'
call fTabAdd ft, 'fl5' , '%8.3I'
call fTabAdd ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure expose m.
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = .eins
m.tstCsv.c.3 = .zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstCSV2: procedure expose m.
/*
$=/tstCSV2/
### start tst tstCSV2 #############################################
w: ¢f1=1 fZwei=eins fDr=r!
w: ¢f1=2 fZwei= zwei , 2 fDr=!
w: ¢f1=3 fZwei=schluss fDr=!
W: ¢F1=1 FZWEI=eins FDR=r!
W: ¢F1=2 FZWEI= zwei , 2 FDR=!
W: ¢F1=3 FZWEI=schluss FDR=!
c: ¢f1=1 fComma=eins fDr=r!
c: ¢f1= 2 fComma= zwei , 2 fDr=!
c: ¢f1=3 fComma=schluss fDr=!
C: ¢F1=1 FCOMMA=eins FDR=r!
C: ¢F1= 2 FCOMMA= zwei , 2 FDR=!
C: ¢F1=3 FCOMMA=schluss FDR=!
o: ¢f1=1 fCol=eins fDr=drei fVie=und vier!
o: ¢f1=222222Z fCol=ccccccccC fDr=dddddddD fVie=vvvvvvvvvvvvvv V!
o: ¢f1=3 fCol=schluss fDr=drei fVie=vier!
O: ¢F1=1 FCOL=eins FDR=drei FVIE=und vier!
O: ¢F1=222222Z FCOL=ccccccccC FDR=dddddddD FVIE=vvvvvvvvvvvvvv V!
O: ¢F1=3 FCOL=schluss FDR=drei FVIE=vier!
$/tstCSV2/
*/
call jIni
call tst t, "tstCSV2"
b = jBuf(' f1 fZwei fDr ', '1 eins r', ' 2 " zwei , 2 "',
, '3 schluss')
call tstCsv22 t, 'w', csvWordRdr(b)
call tstCsv22 t, 'W', csvWordRdr(b, 'u')
b = jBuf(' f1 , fComma, fDr ', '1,eins,r', ' 2 ," zwei , 2 "',
, '3,schluss')
call tstCsv22 t, 'c', csv2ObjRdr(b)
call tstCsv22 t, 'C', csv2ObjRdr(b, 'u')
b = jBuf(' > f1 >< fCol <fDr fVie',
,' 1eins drei und vier ',
,'222222ZccccccccCdddddddDvvvvvvvvvvvvvv V',
,' 3 schluss dreivier')
call tstCsv22 t, 'o', csvColRdr(b)
call tstCsv22 t, 'O', csvColRdr(b, 'u')
call tstEnd t
return
endProcedure tstCSV2
tstCSV22: procedure expose m.
parse arg t, l, c
call jOpen c, '<'
do while jRead(c)
call tstOut t, l':' o2TexLR(m.c, , '¢', '!')
end
call jCLose c
return
endProcedure tstCSV22
tstCSVExt: procedure expose m.
/*
$=/tstCsvExt/
### start tst tstCsvExt ###########################################
v,string eins, oder nicht?
v,
w,string_W zwei, usw,,,|
c TstCsvExtF class@TstCsvExtF,u f FEINS v,f FZWEI v
o class@TstCsvExtF o1,f1Feins,"f1,fzwei "
c TstCsvExtG class@TstCsvExtG,u f gDrei v,f GVIER v,f gRef r o
f class@TstCsvExtG objG4,
d class@TstCsvExtG objG4,objG4gDrei,objG4.gVier,objG4
d class@TstCsvExtG objG3,,objG3.gVier,objG4
o class@TstCsvExtG G2,g2gDrei,,objG3
b TstCsvExtH class@TstCsvExtH,
m metEins method@metEins,call a b,c,"d e",
c TstCsvExtH class@TstCsvExtH,u v,f rr r o,f rH r class@TstCsvExtH,+
method@metEins
f class@TstCsvExtH H5,
d class@TstCsvExtH H9,H9value,objG3,H5
d class@TstCsvExtH H8,H8value rrWText,!escText,H9
d class@TstCsvExtH H7,H7value rrText,!textli,H8
d class@TstCsvExtH h6,h6-value6 rrLeer,,H7
o class@TstCsvExtH H5,h5Value,o1,h6
$/tstCsvExt/
*/
call jIni
call tst t, "tstCsvExt"
m = 'TST_CsvExt'
call csvExtBegin m
m.o.0 = 0
cF = classNew('n? TstCsvExtF u f FEINS v, f FZWEI v')
cG = classNew('n? TstCsvExtG u f gDrei v, f GVIER v, f gRef r')
cH = class4Name('TstCsvExtH', '-')
if cH == '-' then do
cH = classNew('n TstCsvExtH u')
cH = classNew('n= TstCsvExtH u v, f rr r, f rH r TstCsvExtH',
, 'm metEins call a b,c,"d e",')
end
do cx=1 to m.ch.0 until m.cy == 'm'
cy = m.cH.cx
end
call mAdd t.trans, cF 'class@TstCsvExtF', cG 'class@TstCsvExtG' ,
, cH 'class@TstCsvExtH', cY 'method@'m.cy.name
call csvExt m, o, 'string eins, oder nicht?'
call csvExt m, o
call csvExt m, o, s2o('string_W zwei, usw,,,|')
call csvExt m, o, csv2o('o1',cF, 'f1Feins,"f1,fzwei "')
call csvExt m, o, csv2o(g2, cG, 'g2gDrei,',
|| ','csv2o('objG3', cG, ',objG3.gVier',
|| ','csv2o('objG4', cG, 'objG4gDrei,objG4.gVier,objG4')))
call csvExt m, o, csv2o(h5, cH, 'h5Value,o1',
|| ','csv2o('h6', cH, 'h6-value6 rrLeer,',
|| ','csv2o(h7, cH, 'H7value rrText,textli',
|| ','csv2o(h8, cH, 'H8value rrWText,!escText',
|| ','csv2o(h9, cH, 'H9value,objG3,H5')))))
call outSt o
call tstEnd t
return
endProcedure tstCSVExt
tstCsvV2F: procedure expose m.
/*
$=/tstCsvV2F/
### start tst tstCsvV2F ###########################################
abcd
abcde
abcd&
ef
abc |
abcd&
. |
abcd&
e |
abc&|
abcd&
||
abcd&
e&|
abcd&
efgh
abcd&
efghi
abcd&
efgh&
ij
abcd&
efgh&
ij |
abcd&
efgh&
ijk&|
abcd&
efgh&
ijkl&
||
* f2v
abcd
abcde
abcdef
abc .
abcd .
abcde .
abc&
abcd|
abcde&
abcdefgh
abcdefghi
abcdefghij
abcdefghij .
abcdefghijk&
abcdefghijkl|
* f2v zwei
begin zwei
*** err: csvF2vEnd but strt='drei '
$/tstCsvV2F/
*/
call jIni
call tst t, "tstCsvV2F"
m = 'TST_csvV2F'
call csvV2FBegin m, 5
m.o.0 = 0
call mAdd mCut(i1, 0), 'abcd' ,
, 'abcde' ,
, 'abcdef' ,
, 'abc ' ,
, 'abcd ' ,
, 'abcde ' ,
, 'abc&' ,
, 'abcd|' ,
, 'abcde&' ,
, 'abcdefgh' ,
, 'abcdefghi' ,
, 'abcdefghij' ,
, 'abcdefghij ' ,
, 'abcdefghijk&' ,
, 'abcdefghijkl|'
do ix=1 to m.i1.0
call csvV2F m, o, m.i1.ix
end
call outSt o
call tstOut t, '* f2v'
m.p.0 = 0
call csvF2VBegin m
do ox=1 to m.o.0
call csvF2V m, p, m.o.ox || left(' ', ox // 3)
end
call csvF2VEnd m
call outSt p
call tstOut t, '* f2v zwei'
call mAdd mCut(o2, 0), 'begin zwei', 'drei &'
call csvF2VBegin m
call csvF2V m, mCut(p, 0), m.o2.1
call csvF2V m, p, m.o2.2
call outSt p
call csvF2VEnd m
call tstEnd t
say 'test with 1sRdr'
call tst t, "tstCsvV2F"
b1 = jBuf()
call mAddSt b1'.BUF', i1
call jIni
j1s = csvV2FRdr(b1, 5)
call jWriteAll t, j1s
call tstOut t, '* f2v'
call mAddSt mCut(b1'.BUF', 0), o
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstOut t, '* f2v zwei'
call mAddSt mCut(b1'.BUF', 0), o2
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstEnd t
return
endProcedure tstCsvV2F
tstCsvInt: procedure expose m.
/*
$=/tstCsvInt/
### start tst tstCsvInt ###########################################
wie geht es, "Dir", denn? .
tstR: @ obj null
wie geht es, "Dir", denn? class_W .
tstR: @tstWriteoV1 isA :TstCsvIntF*2
tstR: .FEINS = f1Feins
tstR: .FZWEI = f1,fzwei .
tstR: @tstWriteoV3 isA :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 done :TstCsvIntG*4 @tstWriteoV3
tstR: @tstWriteoV5 isA :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 done :TstCsvIntG*4 @tstWriteoV5
metEins=call out o, "calling metEins" m.m.R1
$/tstCsvInt/
*/
call jIni
call tst t, "tstCsvInt"
i = 'TST_csvInt'
call csvIntBegin i
call csvInt i, mCut(o, 0), 'v,wie geht es, "Dir", denn? '
call csvInt i, o, 'v,'
call csvInt i, o, 'w,wie geht es, "Dir", denn? class_W '
call csvInt i, o, 'c TstCsvIntF ClassIF,u f FEINS v,f FZWEI v'
call csvInt i, o, 'o ClassIF o1,f1Feins,"f1,fzwei "'
call csvInt i, o, 'b TstCsvIntG ClassIG'
call csvInt i, o, 'm metEins adrM1,call out o,' ,
'"calling metEins" m.m.R1'
call csvInt i, o, 'c TstCsvIntG ClassIG,u v, f R1 r ClassIG, adrM1'
call csvInt i, o, 'f ClassIG o4,'
call csvInt i, o, 'd ClassIG o3,o3Value,o4'
call csvInt i, o, 'o ClassIG o4,o4Value,o3'
call csvInt i, o, 'r o3,'
do ox=1 to m.o.0
call tstTransOc t, m.o.ox
end
call outSt o
ox = m.o.0
call out 'metEins='objMet(m.o.ox, 'metEins')
call tstEnd t
return
endProcedure tstCsvInt
tstfUnits: procedure
/*
$=/tstfUnits/
### start tst tstfUnits ###########################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0f =-> -0f =+> +0f =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000f =-> -0.000f =+> +0.000f =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -19E =+> +19E =b> 16.083E
. 20.987E20 ==> 2099E =-> -2099E =+> +2099E =b> 1820E
$/tstfUnits/
$=/tstfUnitst/
### start tst tstfUnitst ##########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstfUnitst/ */
call jIni
call tst t, "tstfUnits"
numeric digits 9
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd') ,
'=->' fUnits( '-'word(lst, wx), 'd') ,
'=+>' fUnits( word(lst, wx), 'd', , , '+'),
'=b>' fUnits( word(lst, wx), 'b')
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd', 7, 3) ,
'=->' fUnits( '-'word(lst, wx), 'd', 7, 3) ,
'=+>' fUnits( word(lst, wx), 'd', 7, 3, '+'),
'=b>' fUnits( word(lst, wx), 'b', 7, 3)
end
call tstEnd t
call tst t, "tstfUnitst"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 't' ) ,
'++>' fUnits( word(lst, wx), 't', , , ' '),
'-+>' fUnits('-'word(lst, wx), 't' ),
'-->' fUnits('-'word(lst, wx), 't', , , ' ')
end
call tstEnd t
return
endProcedure tstfUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph missing
. e 1: last token " scanPosition noEnd
. e 2: pos 28 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 " v=noEnd
$/tstSb/ */
call pipeIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
$/tstSb2/ */
call pipeIni
call tst t, 'tstSb2'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph missing
. e 1: last token ' scanPosition wie 789abc
. e 2: pos 7 in string a034,'wie 789abc
scan w tok 1: w key val wie 789abc
scan n tok 2: ie key val wie 789abc
scan s tok 1: key val wie 789abc
*** err: scanErr illegal char after number 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val wie 789abc
scan n tok 3: abc key val wie 789abc
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha q3 = f ab=cdEf eF='strIng' .
scan s tok 1: key val .
scan k tok 0: key aha val def
scan k tok 1: f key q3 val f
scan s tok 1: key q3 val f
scan k tok 4: cdEf key ab val cdEf
scan s tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan s tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'k1'," aha q3 = f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
/*--- one single test scan with lines to scan in stem ln ------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSrc scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
if a2 == 0 then
res = scanNatIA(s)
else
res = scanNat(s)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jRead(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
/*
$=/tstScanReadPos/
### start tst tstScanReadPos ######################################
1
2
345678
4
5678
4
$/tstScanReadPos/ */
call tst t, 'tstScanReadPos'
b = jBuf(1, 2, 345678, 4)
call scanReadOpen scanReadReset(scanOpt(tstScn), b)
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call scanSetPos tstScn, 3 3
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinPos/
### start tst tstScanWinPos #######################################
infoA1 1: last token 1 scanPosition 2 +
. 3\npos 2 in line 1: 1
1
2
345678
4
infoB1: last token scanPosition \natEnd after line 4: 4
infoC1: last token scanPosition 678 4\npos 4 in line+
. 3: 345678
678
4
infoA0 1: last token -2 scanPosition -1 -0 1 +
. 2\npos 3 in line -2: -2
-2
-1
-0
1
2
345678
4
infoB0: last token scanPosition \natEnd after line 4: 4
infoC0: last token scanPosition 5678 4\npos 3 in line 3: 345678
5678
4
$/tstScanWinPos/ */
call tst t, 'tstScanWinPos'
b = jBuf(1, 2, 345678, 4)
do ox=1 to 0 by -1
if ox then
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 20))
else
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 10),
,'-2 -1 -0')
do nx=1 while scanNum(scanSkip(s))
if nx = 1 then
call tstOut t, 'infoA'ox nx':' scanInfo(s)
call tstOut t, m.s.tok
end
call tstOut t, 'infoB'ox':' scanInfo(s)
call scanSetPos s, 3 3+ox
call tstOut t, 'infoC'ox':' scanInfo(s)
do while scanNat(scanSkip(s))
call tstOut t, m.s.tok
end
call scanClose s
end
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr bad unit TB after +9..
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlClass/
### start tst tstScanSqlClass #####################################
i a 1 A
d "bC" 1 bC
q d.e 2 D.E
q f." g".h 3 F. g.H
s 'ij''kl' 3 ij'kl
s x'f1f2' 3 12
s X'f3F4F5' 3 345
.. . 3 .
n .0 3 .0
n 123.4 3 123.4
n 5 3 5
i g 1 G
$/tstScanSqlClass/ */
call tst t, 'tstScanSqlClass'
b = jBuf('a "bC" d.e f." g".h' "'ij''kl' x'f1f2' X'f3F4F5'" ,
, '. .0 123.4 5 g')
h = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while scanSqlClass(h)
call tstOut t, m.h.sqlClass m.h.tok m.h.val.0 m.h.val
end
call tstEnd t
return
endProcedure tstScanSql
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
/*??????????????? remove ?????????????????
--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return ???????remove????? */
/**** tst: test infrastructure ***************************************/
/*--- test hook -----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg m, rest
do wx=1 to words(rest)
interpret 'call tst'word(rest, wx)
end
if wx > 2 then
call tstTotal
if wx > 1 then
return ''
/* default test */
say ii2rzdb(ee)
say ii2rzdb(eq)
say ii2rzdb(eq)
do y = left(date('s'), 4) - 17 to left(date('s'), 4) + 7
say y timeYear2Y(y) timeY2Year(timeYear2Y(y))
end
do y = left(date('s'), 4) - 69 to left(date('s'), 4) + 30
say y timeYear24(substr(y, 3))
end
d = date('s')
say d 'b' date('b', d , 's')
say d 'b' date('b', 20150101, 's') 'jul' date('j')
say d 'l14' date('b', 20150101, 's') - date('b', 20140101, 's')
say d 'l16' date('b', 20170101, 's') - date('b', 20160101, 's')
say funits(3e7, 'd')
call err tstEnd
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect
return ''
endProcedure wshTst
/*--- initialise m as tester with name nm
use inline input nm as compare lines ------------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'hos', 'return tstErrHandler(ggTxt)'
call sqlRetDef
m.m.errCleanup = m.err_cleanup
m.tst_m = m
if m.tst.ini.j == 1 then do
m.m.jWriting = 0
call jOpen jReset(oMutatName(m, 'Tst')), '>'
m.m.in.jReading = 0
call jOpen jReset(oMutatName(m'.IN', 'Tst')), '<'
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err_cleanup then
call tstErr m, 'err_cleanup' m.err_cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
/*--- tstIni: global initialization ---------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
m.tst_csmRz = 'RZZ'
m.tst_csmDb = 'DE0G'
m.tst_csmRzDb = m.tst_csmRz'/'m.tst_csmDb
m.tst_csmServer = 'CHROI00ZDE0G'
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jOpen",
, "jRead if \ tstRead(m, rStem) then return 0",
, "jWrite call tstWriteBuf m, wStem"
end
if m.tst.ini.e \== 1 & m.pipe_ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ---------------------*/
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
arg = repAll(arg, 'in' m.myWsh':', 'in wsM:')
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteBuf: procedure expose m.
parse arg m, wStem
if wStem == m'.BUF' then do
xStem = mAddSt(mCut(wStem'_tstWriteXStem', 0), wStem)
m.wStem.0 = 0 /* attention avoid infinite recursion | */
end
else
xStem = wStem
do wx=1 to m.xStem.0
call tstWrite m, m.xStem.wx
end
return
endProcedure tstWriteBuf
tstWrite: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N then do
call tstOut m, 'tstR: @ obj null'
end
else if cl == m.class_S then do
call tstOut m, var
end
else if abbrev(var, m.o_escW) then do
call tstOut m, o2String(var)
end
else if cl == m.class_V then do
call tstOut m, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut m, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut m, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut m, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut m, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call tstTransOC m, var
call classOut , var, 'tstR: '
end
return
endProcedure tstWrite
tstTransOC: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return
c1 = className(cl)
vF = 0
do tx=m.m.trans.0 by -1 to 1 until vF & c1 == ''
if word(m.m.trans.tx, 1) == var then
vF = 1
if word(m.m.trans.tx, 1) == c1 then
c1 = ''
end
if \ vF then
call mAdd M'.TRANS', var 'tstWriteoV' ||(m.m.trans.0+1)
if c1 == '' then nop
else if m.cl.name == '' then
call mAdd M'.TRANS', c1 'class*' ||(m.m.trans.0+1)
else if m.cl.name \== m.cl.met then
call mAdd M'.TRANS', c1 m.cl.met ||(m.m.trans.0+1)
return
endProcedure tstTransOC
/*--- translate the tst_csm* variables ------------------------------*/
tstTransCsm: procedure expose m.
parse arg t
say 'csm to' m.tst_csmRzDb m.tst_csmServer
call mAdd t.trans, m.tst_csmRZ '<csmRZ>' ,
, m.tst_csmDb '<csmDB>' ,
, m.tst_csmServer '<csmServer>'
s2 = iirz2sys(m.tst_csmRz)
do sx=0 to 9
call mAdd t.trans, s2 || sx '<csmSys*>'
end
return
endProcedure tstTransCsm
tstRead: procedure expose m.
parse arg mP, rStem
if right(mP, 3) \== '.IN' then
call err 'tstRead bad m' mP
m = left(mP, length(mP)-3)
ix = m.m.inIx + 1
m.m.inIx = ix
m.rStem.0 = ix <= m.mP.0
m.rStem.1 = m.mP.ix
if ix <= m.m.in.0 then
call tstOut m, '#jIn' ix'#' m.m.in.ix
else
call tstOut m, '#jIn eof' ix'#'
return m.rStem.0
endProcedure tstRead
tstFilename: procedure expose m.
parse arg suf, opt
if m.err_os == 'TSO' then do
parse value dsnCsmSys(suf) with sys '/' suf
dsn = dsn2jcl('~tmp.tst.'suf)
if sys \== '*' then
dsn = sys'/'dsn
if opt = 'r' then do
if dsnExists(dsn) then
call dsnDel dsn
do fx=1 to dsnList(tstFileName, dsn)
call dsnDel m.tstFileName.fx
end
end
return dsn
end
else if m.err_os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err_os
endProcedure tstFilename
/*--- say total errors and fail if not zero -------------------------*/
tstTotal: procedure expose m.
say '######'
/* say '###### astStatsTotals'
do sx=1 to words(m.comp_astStats)
k = word(m.comp_astStats, sx)
say f('%5c %7i %7i %7i', k, m.comp_astStats.k,
, m.comp_astStatT.k, m.comp_astStat1.k)
end
say '######' */
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue ----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors -------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, 0, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstData -------------------------------------------------------*/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFldD(fo)
do fx=1 to m.ff.0
f = fo || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFldD(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || m.ff.fx
m.f = tstData(m.f, substr(m.ff.fx, 2),
, '+'substr(m.ff.fx,2)'+', x)
end
call out o
end
return
endProcedure tstDataClassOut
/* copy tstAll end **************************************************/
/* copy unused begin *************************************************/
class2srcMap: procedure expose m.
parse arg m
call mapReset m
call mapPut m, m.class_v, 'v'
call mapPut m, m.class_w, 'w'
call mapPut m, m.class_o, 'o'
return m
endProcedure class2srcMap
tstClass2src: procedure expose m.
/*
$</class2src/
$/class2src/
*/
call jIni
call tst t, 'class2src'
done = class2SrcMap(tstClass2SrcMap)
call class2src m.class_class, done, t
call class2src m.class_jrw, done, t
call class2src m.class_jrwLazy, done, t
call tstEnd t
return
endProcedure class2srcMap
class2src: procedure expose m.
parse arg cl, done, out
res = mapGet(done, cl, '-')
if res \== '-' then
return res
call mapPut done, cl, cl
ty = m.cl
res = 'class' cl':'
if ty == 'u' then do
if m.cl.name == '' then
res = res 'u'
else if right(m.cl.met, 1) \== '*' then
res = res 'n' m.cl.name 'u'
else
res = res 'n*' left(m.cl.met, length(m.cl.met)-1)
if m.cl.0 > 0 then do
do cx=1 to m.cl.0
res = res class2SrcEx(m.cl.cx, done, out)','
end
res = left(res, length(res)-1)
end
end
else if ty == 'm' & m.cl.0 == 0 then
res = res 'm' m.cl.name m.cl.met
else
res = res class2SrcEx(cl, done, out)
call jWrite out, res
return cl
endProcedure class2src
class2srcEx: procedure expose m.
parse arg cl, done, out
res = ''
ch = cl
do forever
g = mapGet(done, cl, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res class2Src(ch, done, out))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('class2src bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure class2srcEx
/**********************************************************************
lmd: catalog read ===> ersetzt durch csi
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
**********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
tstLmdTiming:
parse arg lev
trace ?r
lev = word(lev DSN , 1)
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
/**********************************************************************
==> abgeloest mbrList: tso listDS "'"dsn"'" members
member list of a pds: ==> abgeloest mbrList tso
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
**********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- find archived DSN's from listCat ------------------------------*/
listCatClass: procedure expose m.
parse upper arg dsn
rt = adrTso("listcat volume entry('"dsn"')", 4)
/* say 'listct rc =' rt 'lines' m.tso_trap.0 */
cl = ''
vo = ''
if word(m.tso_trap.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
else if pos('NOT FOUND', m.tso_trap.1) > 0 then
return 'notFound'
else if word(m.tso_trap.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
do tx=2 to m.tso_trap.0 while vo = '' ,
& left(m.tso_trap.tx, 1) = ' '
/* say m.tso_trap.tx */
p = pos('MANAGEMENTCLASS-', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+16), 1), 'l', '-')
p = pos('VOLSER--', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', m.tso_trap.tx)
dt = strip(word(substr(m.tso_trap.tx, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/**** sql stored procedures ******************************************/
/*--- sql call statement ---------------------------------------------
old code: find procedure description in catalog
and use it to create call statement --------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
tstSqlStored: procedure expose m.
call sqlConnect 'DP4G'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
/*--- sql trigger timing --------------------------------------------*/
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 'select max(pri) MX from' tb, cc
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlCommit
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
/*******????? neu, noch versorgen ???????? ***************************/
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut_lc)
c1 = substr(m.ut_lc, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jReadVar(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl)
nm = substr(m.fl, lastPos('/', m.fl)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
/* copU fiLinux begin ************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet ----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, wStem",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copU fiLinux end ************************************************/
/* copy unused end *************************************************/
}¢--- A540769.WK.REXX(CAXOLD) cre=2016-07-16 mod=2016-07-17-23.48.39 A540769 ---
/* rexx ----------------------------------------------------------------
Credit Suisse line commands in RCQ walter 28. 4.16
c1 : db2 catalog rows for this line
cx : db2 catalog rows for all lines of currently displayed list
rts or r1: realTimeStats rows for this line
rx : realTimeStats rows for all lines of currently displayed list
The above commands show their result in an editSession
you find the selection path and sql at the bottom
within this editSession the same commands act as editMacros
$br or $ed: browse or edit table on this line with fileAid
editMacros
cx in command line: show data as table (one row a line)
c1 in command line and cursor on target line:
show data for selected line, one column a line
rx in command line: show related realTimeStats as table
rts or r1 in command line and cursor on target line:
show realTimeStats related to selected line, one column a line
the above editMacros allow arguments to select related db2 objects
e.g. cx pk: related packages, cx ik: related index keys
the syntax for the argumnts is richer: ct* (':' ct)?
ct: abbreviations for db2 catalog tables (lowercase|)
c co=syscopy db i ik=indexKey ip pk pkd ri rt t tg tp ts v vd
ct before the colon
first: target catalog table
following: intermediates on the new selection path
ct after the colon: starting point in the old selection path
$br or $ed: browse or edit table on cursor line with fileAid
{u
ux: erstellt utilities/rebinds fuer angezeigte Objekte
macro arguments: Liste von Utilities, abkuerzung erlaubt:
copy cd=checkData ce=checkDataExceptionTables ci=checkIndex
loaddummy=dummy reorg runstats
rebind=rbind rebuild=build recover=rcover unload
help: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.CaCatCx {
history
toDo: mit neuem F module alle RBAs auf timestamp uebersetzen
18. 4.16 walter : mit runstats profile fuer umgestellte RZ, unload
------------------------------*/ /*--- end of help ---------------------
12. 4.16 walter : neue recover views
22.12.15 stephan: class=m1, reorg mit auto mappingtable
1.10.15 walter: recover (cx rc und ux rc) auch fuer xDocs eingebaut
cx co verschoenert
21.12.15 walter: fadCall statt rCallFAD
18.02.15 walter: rba for v11 and allow wildcard=*
28.11.13 walter: exceptionTB mit including identity
20.11.13 walter: exceptionTB inherits BP, added missing end in anaList
13.11.13 walter: variable length keys empty or with . (pk|)
4.11.13 walter: pit_rba in recovery und scroll left
20. 8.13 walter: variable length keys in ganzer Laenge am Schluss
19. 8.13 walter: cd, ce, ci checkData/Exceptions, checkIndex
13. 6.13 walter: neuer server name
19. 4.13 walter: $ed,$br,rts=r1 +rx, help fuer cx etc. ohne ux, errors
17. 4.13 walter: fix relation c <-> t v
4. 4.13 walter: fix copy parallel
3. 4.13 walter: fix c1/r1 auf ts, relationship tg -> t v
?. 3.13 walter: neu geschrieben
----------------------------------------------------------------------*/
parse arg who, a1, a2, a3
m.cmd = who
call errReset 'hi'
m.err.helpOpt = if(translate(left(who, 1)) = 'U', 'u', 'e')
m.debug = 0
/* say 'exectst(cax) 12.4.16' who '('a1',' a2',' a3')' */
isEdit = 0
if a1 == '' then
if m.err.ispf then
isEdit = adrEdit('macro (a1) PROCESS', '*') == 0
if pos('?', who a1 ) > 0 then
exit help()
call utIni
call pipeIni
call scanReadIni
call tkrIniDb2Cat
if who == 'CX'| who == 'C1' then do
if isEdit then
return catEditMacro('=', who == 'CX', a1)
else
return catLineCmd('=', who == 'CX')
end
else if who = 'RX' | who == 'R1' | who == 'RTS' then do
if isEdit then
return catEditMacro('r', who == 'RX', a1)
else
return catLineCmd('r', who == 'RX')
end
else if who == 'UX' | who == 'U1' then do
if isEdit then
return uxEditMacro('ux', a1, who == 'UX')
else if a1 == '' then
return uxLineCmd()
end
else if who == '$ED' then
return fileAid(isEdit, 'edit')
else if who == '$BR' then
return fileAid(isEdit, 'browse')
else
call errHelp 'command='who 'args='a1 'edit='isEdit 'not implemented'
exit
catLineCmd: procedure expose m.
parse arg ty, all
m='cat'
if all then
sq = anaSqlAll(m)
else
sq = anaSqlThis(m)
if ty == 'r' then do
parse var sq sTys ':'
sTy = word(sTys, 1)
sq = if(pos('i', sTy) > 0, 'ri', 'rt') sq
end
else if ty \== '=' then
call err 'bad ty' ty 'in catLineCmd'
parse var sq sTys ':' wh
sTy = word(sTys, 1)
call sqlConnect m.m.dbSy
call pipe '+F', fEdit('::v')
call out ' *' m.m.func '? = help, PF3 = zurück zu' ,
'rcQuery' m.m.hTb m.m.hOp
call sqlCatTb sTy, tkrWhere(,sq), tkrTable(, sTy, 'o'), all
call pipe '-'
call sqlDisconnect
return 0
endProcedure catLineCmd
catEditMacro: procedure expose m.
parse arg ty, all, pPa ':' sPa
m='cat'
call anaEdit m, all
nPa = ''
do px=1 to words(pPa)
nd = word(pPa, px)
if abbrev(nd, '-') then
call handleOpt nd
else if tkrTable(tkr, nd, , '') \== '' then
nPa = nPa nd
else
call err 'i}'nd 'not a table in path' arg(3)
end
if nPa = '' then
nPa = word(m.m.path, 1)
if sPa = '' then
sPa = word(m.m.path, 1)
else if \ all then
call err 'i}startPath :'sPa 'not allowed for' m.m.func
px = wordPos(sPa, m.m.path)
if px < 1 then
call err 'i}start' sPa 'not in path' m.m.path 'args:' nPa':'sPa
if ty == 'r' then
nPa = if(pos('i', word(nPa, 1)) > 0, 'ri', 'rt') nPa
else if ty \== '=' then
call err 'bad ty' ty
if all then do
sx = m.m.sql.0 + 1 - px
sq = m.m.sql.sx
parse var sq sFr sTb sAl . 'where' wh
if sAl \== sPa then
call err 'i}start' sPa '<> al' sAl 'in' sq
sTb = tkrTable(tkr, sPa, , '')
if '' == sTb then
call err 'i}start' sPa 'not a table'
wh = strip(wh)
if abbrev(wh, m.sTb.cond) then
wh = strip(substr(wh, length(m.sTb.cond)+1))
else
call err sPa 'cond' m.sTb.cond 'does not start where:' wh
/* if sx > 1 then do
pPa = word(m.m.path, px+1)
if m.tkr.sPa.pPa == 'relation' then
ky = tkr'.'sPa'.'pPa'.LEF'
else if m.tkr.pPa.sPa == 'relation' then
ky = tkr'.'pPa'.'sPa'.RIG'
else
call err 'relation' sPa'.'pPa 'not declared'
if abbrev(wh, m.ky.cond) then
wh = strip(substr(wh, length(m.ky.cond)+1))
else if m.ky.cond <> '' then
call err sPa 'cond' m.ky.cond 'does not start where:' wh
end ?????? falsche Richtung? */
if px > 1 then do
pPa = word(m.m.path, px-1)
if symbol('m.tkr.t2t.sPa.pPa') == 'VAR' then
ky = m.tkr.t2t.sPa.pPa'.LEF'
else if symbol('m.tkr.t2t.pPa.sPa') == 'VAR' then
ky = m.tkr.t2t.pPa.sPa'.RIG'
else
call err 'relationShip' sPa'.'pPa 'not declared'
if abbrev(wh, m.ky.cond) then
wh = strip(substr(wh, length(m.ky.cond)+1))
else
call err sPa 'cond' m.ky.cond 'does not start where:' wh
end
do lx = sx-1 by -1 to 1
wh = wh m.m.sql.lx
end
bc = m.m.sql.0 - 1
do bx = length(wh) by -1 to 1 while bc > sx - 1
b1 = substr(wh, bx, 1)
if b1 = ')' then
bc = bc - 1
else if b1 \== ' ' then
leave
end
wh = strip(left(wh, bx))
end
else do
px = 1
sKy = mGet(tkrTable(, sPa)'.PKEY')
wh = list2where(m'.LST', sKy)
end
nTy = word(nPa, 1)
call sqlConnect m.m.dbSy
b = jBuf()
call pipe '+F', b
call out m.m.help
call sqlCatTb nTy, tkrWhere(, nPa sPa':' wh),
, , all,
, if(all, subWord(m.m.path, px+1))
call pipe '-'
call adrEdit 'delete .zf .zl'
call adrEdit 'reset'
do bx=1 to m.b.buf.0
li = m.b.buf.bx
call adrEdit 'line_after .zl = (li)'
end
call sqlDisconnect
call adrEdit 'locate .zf'
call adrEdit 'left max'
return 1
endProcedure catEditMacro
handleOpt: procedure expose m.
parse upper arg opt
m = 'cat'
if opt == '-RU' then
call adrTso "ex 'dsn.db2.exec(tecSvUnl)' '"m.m.dbSy"'", '*'
else
call err "i}option '"opt"' not supported"
return
endProcedure handleOpt
fileAid: procedure expose m.
parse arg isEdit, faFun
m='cat'
if isEdit then do
call anaEdit m, 1
l = m'.LST'
m.l.0 = 0
call anaList m, tkrTable(, word(m.m.path, 1)), 0
if m.l.0 = 1 & m.l.alias = 't' then
return callFA(faFun, m.m.dbSy, m.l.1.2, m.l.1.1)
call err 'i}not a single table but' m.l.0 m.l.alias
end
else do
sq = anaSqlThis(m)
if m.m.lTb == 't' then
return callFA(faFun, m.m.dbSy, m.m.lNm, m.m.lQu)
call err 'i}not a single table but' m.m.lTb
end
endProcedure fileAid
callFA: procedure expose m.
parse arg faFun, dbSy, tb, cr
call adrTso "exec 'dsn.db2.exec(fadCall)' '"faFun dbSy tb cr"'"
return 0
endProcedure callFAD
uxLineCmd: procedure expose m.
m='ux'
call anaSql m
call sqlConnect m.m.dbSy
fe = jOpen(fEdit(), '>')
call jWrite fe, 'who' sysvar(sysnode) m.m.dbSy userid() m.m.screen
call jWrite fe, 'sel' cTy m.m.hCr'.'m.m.hNm
call sql2St 'select creator cr, name tb, dbName db, tsName ts',
genSql(m, 't'), sq
if m.sq.0 <> m.m.lines then
say 'warning: select' m.sq.0 'rows <->' m.m.lines 'on screen',
'this might be a program ERROR|'
do sx=1 to m.sq.0
call jWrite fe, ' ts' left(m.sq.sx.db'.'m.sq.sx.ts,18) ,
't' m.sq.sx.cr'.'m.sq.sx.tb
end
call sqlDisconnect
call jCLose(fe)
return 0
endProcedure uxLineCmd
anaSqlAll: procedure expose m.
parse arg m
call getInfo m
m.m.predFlds = '? ? HNM HCR HQU HPKVERS HROVERS'
return anaSql(m, m.m.hTb, m.m.hOp)
endProcedure anaSqlAll
anaSqlThis: procedure expose m.
parse arg m
call getInfo m
m.m.predFlds = '? ? LNM LQU PART LPANM COLLECTION CONTOKEN VERSION'
ty = m.m.lTb
if ty == 'c' & m.m.hTb == 'i' then
return anaPred(m, 'ik', 'ikk.colName', 'creator', , 'name')
else if ty == 'c' & wordPos(m.m.hTb, 't v') > 0 then
return anaPred(m, 'c', 'name', 'tbCreator', , 'tbName')
else if ty == 'ip' then
return anaPred(m, 'ip', 'ixname', 'ixCreator', 'partition')
else if ty == 'pk' then
return anaPred(m, 'pk', 'name', 'owner',,, 'collid',
, 'conToken', 'version')
else if ty == 'tg' & m.m.hTb == 't' then
return anaPred(m, 'tg', 'name', 'tbOwner', , 'tbName')
else if ty == 'ts' then
return anaPred(m, 'ts', 'name', 'dbName')
else if ty == 'tp' then
return anaPred(m, 'tp', 'tsname', 'dbName', 'partition')
else
return anaSql(m, ty, 'd')
endProcedure anaSqlThis
anaSql: procedure expose m.
parse arg m, ty, op
tyOp = ty':'op
if ty == 'c' then
sq = anapred(m, 'c', 'name', 'tbCreator')
else if tyOp == 'db:i' then
sq = anapred(m, 'i', 'dbName')
else if tyOp == 'db:t' | tyOp = 'db:v' then
sq = anapred(m, 't', 'dbName')
else if tyOp == 'db:ts' then
sq = anapred(m, 'ts', 'dbName')
else if ty = 'db' then
sq = anapred(m, 'db', 'name')
else if tyOp == 'i:c' then
sq = anaPred(m, 'ik', 'name', 'creator')
else if tyOp == 'i:pl' then
sq = anaPred(m, 'ip', 'ixName', 'ixCreator')
else if ty == 'i' then
sq = anaPred(m, 'i', 'name', 'creator')
else if ty == 'pk' then
sq = anaPred(m, 'pk', 'name', 'owner', 'collid', 'version')
else if tyOp == 't:i' then
sq = anaPred(m, 'i', 'tbName', 'tbCreator')
else if tyOp == 't:tg' then
sq = anaPred(m, 'tg', 'tbName', 'tbOwner')
else if ty == 't' then
sq = anaPred(m, 't', 'name', 'creator')
else if ty == 'tg' then
sq = anaPred(m, 'tg', 'name', 'tbOwner')
else if tyOp == 'ts:pl' then
sq = anaPred(m, 'tp', 'tsName', , 'dbName')
else if ty == 'ts' then
sq = anaPred(m, 'ts', 'name', 'creator', 'dbName')
else if ty == 'v' then
sq = anaPred(m, 'v', 'name', 'creator')
else
call err 'type:opt' tyOp 'not implemented yet'
if tyOp == 'i:d' then
return 'ip' sq
else if tyOp == 'ts:d' then
return 'tp' sq
if op == 'l' | op == 'd' | op == 'pl' | tyOp = 'i:c' then
return sq
else
return op sq
endProcedure anaSql
anaPred: procedure expose m.
parse arg m, ty
sq = ''
do ax=3 to arg()
f1 = word(m.m.predFlds, ax)
if f1 \== '' then
sq = strip(sq tkrPred( , ty, arg(ax), m.m.f1))
end
return ty':' substr(sq, 5)
endProcedure anaPred
/*--- copy tkr begin ---------------------------------------------------
table key relationship
----------------------------------------------------------------------*/
tkrTable: procedure expose m.
parse arg m, key, wh
if m == '' then
m = tkr
dx = pos('.', key)
if dx < 1 then
mt = m'.t.'key
else
mt = key
if m.mt \== 'table' then
if arg() >= 4 then
return arg(4)
else
call err 'not a table' key', mt' mt'->'m.mt
if wh == '' then
return mt
else if wh == 't' then
return m.mt.table
else if wh == 'o' then
return m.mt.order
else if wh == 'f' then
return 'from' m.mt.table 'where' m.mt.cond
else if wh == 'w' then
return m.mt.cond
else if wh == 'e' then
return m.mt.editFun
else
call err 'bad what' wh 'in tkrTable('m',' tb',' wh')'
endProcedure tkrTable
tkrWhere: procedure expose m.
parse arg m, pa ':' wh
if m == '' then
m = tkr
pEx = tkrPath(m, pa)
m.m.path = pEx
sq = wh
do px=words(pEx)-1 by -1 to 1
tt = word(pEx, px)
tf = word(pEx, px+1)
if symbol('m.m.t2t.tt.tf') == 'VAR' then
parse value m.m.t2t.tt.tf 'LEF RIG' with rl fTo fFr
else if symbol('m.m.t2t.tf.tt') == 'VAR' then
parse value m.m.t2t.tf.tt 'RIG LEF' with rl fTo fFr
else
call err 'no relationShip to' tt 'from' tf 'path' pEx,
't.f' m.m.tt.tf 'f.t' m.m.tf.tt
if m.rl.fFr.sql1 \== '' then
sq = m.rl.fFr.sql1 sq')'
else do
kc = min(mGet(m.rl.lef'.'0), mGet(m.rl.rig'.'0))
sq = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')')' ,
'in (select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')'
end
/* kc = min(mGet(m.rl.lef'.'0), mGet(m.rl.rig'.'0))
s2 = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')') in'
if m.rl.fFr.special \== '' then
sq = s2 m.rl.fFr.special sq')'
else
sq = s2 '(select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')'
sq = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')')' ,
'in (select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')' */
end
return sq
endProcedure tkrWhere
tkrPath: procedure expose m.
parse arg m, sPa
res = word(sPa, 1)
do sx=2 to words(sPa)
p1 = tkrPat1(m, word(sPa, sx-1), word(sPa, sx))
if p1 == '' then
call err 'no path to' word(sPa, sx-1) 'from' word(sPa, sx)
res = res subWord(p1, 2)
end
if m.debug then
say '???' sPa '==path==>' res
return res
endProcedure tkrPath
tkrPatChk: procedure expose m.
parse arg m, pa
p2 = space(pa, 1)
do bx=1 to words(m.m.pathBad)
b1 = word(m.m.pathBad, bx)
if abbrev(b1, 1) then do
wx = wordPos(substr(b1, 2), p2)
if wx > 1 & wx < words(p2) then
return ''
end
else if pos('|', b1) > 0 then do
parse var b1 t1 '|' t2
wx = wordPos(t1, p2)
if wx > 1 & wx < words(p2) then
if word(p2, wx-1) \== t2 & word(p2, wx+1) \== t2 then
return ''
end
else if pos('-', b1) > 0 then do
b2 = translate(b1, ' ', '-')
if pos(' 'b2' ', ' 'p2' ') > 0 then
return ''
b3 = ''
do wx=1 to words(b2)
b3 = word(b2, wx) b3
end
if pos(' 'b3' ', ' 'p2' ') > 0 then
return ''
end
else
call err 'bad pathBad word' b1 'in' m.m.pathBad
end
return strip(p2)
endProcedure tkrPatChk
/*--- return path to tt from tf, fail if not unique ------------------*/
tkrPat1: procedure expose m.
parse arg m, tt, tf
m.m.pathRes.0 = 0
call tkrPat3 m, tt, tf
if m.m.pathRes.0 = 1 then
return m.m.pathRes.1
else if m.m.pathRes.0 < 1 then
call err 'no path to' tt 'from' tf
else if m.m.pathRes.0 > 1 then
call err 'multiple ('m.m.pathRes.0') paths to' tt 'from' tf,
mCat(m'.'pathRes, '\n%s%qn\n%s')
endProcedure tkrPat1
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat2: procedure expose m.
parse arg m, tt, tf
call tkrPat3 m, tt, tf
if m.debug then do
say '???' tt '<' tf '--pat2-->' m.m.pathRes.0 'paths'
do px=1 to m.m.pathRes.0
say '???'px'???' m.m.pathRes.px
end
end
return
endProcedure tkrPat2
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat3: procedure expose m.
parse arg m, tt, pa1 paR
pa = tkrPatChk(m, pa1 paR)
if pa == '' then
return
if tt = pa1 then do
/* ok target reached, is there already a shorter path? */
do px=1 to m.m.pathRes.0
if wordsIsSub(pa, m.m.pathRes.px) then
return
end
/* remove all longer paths */
qx = 0
do px=1 to m.m.pathRes.0
if wordsIsSub(m.m.pathRes.px, pa) then
iterate
qx = qx+1
m.m.pathRes.qx = m.m.pathRes.px
end
/* add new path */
qx = qx+1
m.m.pathRes.qx = pa
m.m.pathRes.0 = qx
return
end
/* use direct connection if it exists */
if symbol('m.m.t2t.tt.pa1') == 'VAR' ,
| symbol('m.m.t2t.pa1.tt') == 'VAR' then do
call tkrPat2 m, tt, tt pa1 paR
return
end
tb1 = tkrTable(m, pa1)
/* try all connections from pa1 */
do rx=1 to words(m.tb1.rels)
r1 = word(m.tb1.rels, rx)
if mGet(mGet(m.r1.lef'.TABLE')'.ALIAS') == pa1 then
a1 = mGet(mGet(m.r1.rig'.TABLE')'.ALIAS')
else if mGet(mGet(m.r1.rig'.TABLE')'.ALIAS') == pa1 then
a1 = mGet(mGet(m.r1.lef'.TABLE')'.ALIAS')
else
call err 'relationship' tb1 'not connecting' pa1
if wordPos(a1, pa1 paR) > 0 then
iterate
call tkrPat2 m, tt, a1 pa1 paR
end
return
endProcedure tkrPat3
wordsIsSub: procedure expose m.
parse arg long, short
sW = words(short)
if sW = 0 then
return 1
lW = words(long)
if sW > lW then
return 0
else if sW = lW then
return space(long, 1) == space(short, 1)
if word(long, lW) \== word(short, sW) then
return 0
lX = 1
do sX=2 to sW-1
lx = wordPos(word(short, sX), long, lX+1)
if lX <= 1 | sW-sX > lW-lX then
return 0
end
return 1
endProcedure wordsIsSub
tkrType: procedure expose m.
parse arg m, col
if m == '' then
m = tkr
upper col
if wordPos(col, m.m.numeric) > 0 then
return 'n'
cNQ = substr(col, 1+pos('.', col))
if wordPos(cNQ, m.m.numeric) > 0 then
return 'n'
if wordPos(cNQ, m.m.hex) > 0 then
return 'x'
return 'c'
endProcedure tkrType
tkrValue: procedure expose m.
parse arg m, al, col, val
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
tt = tkrType(m, col)
if tt == 'c' then
return quote(val, "'")
if tt == 'n' then
if datatype(val, 'n') then
return val
else
call err 'not numeric' val 'for col' col
if tt == 'x' then
if verify(val, '0123456789abcdefABCDEF', 'n') < 1 then
return "x'"val"'"
else
call err 'not a hex value' val 'for col' col
call err 'unsupport tkrType' tt
endProcedure tkrValue
tkrPred: procedure expose m.
parse arg m, al, col, va
if col == '-' | col == '' | va == '*' then
return ''
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
va = tkrValue(m, , col, va)
if abbrev(va, "'") then
if verify(va, '*%_', 'm') > 0 then
return 'and' col 'like' translate(va, '%', '*')
return 'and' col '=' va
endProcedure tkrPred
tkrIniDb2Cat: procedure expose m.
parse arg m
call sqlCatIni
if m == '' then
m = tkr
if m.m.ini == 1 then
return
m.m.ini = 1
y = 'sysIbm.sys'
mC = tkrIniT(m, 'c' y'Columns', 'tbCreator tbName name',
, 'tbCreator tbName colNo', , , '1')
mCo =tkrIniT(m, 'co' y'Copy',
, 'dbName tsName dsNum instance timestamp' ,
, 'co.dbName, co.tsName, co.timestamp desc',
,,'sqlCatCopy')
call tkrIniK m, mCo, '1plus', 'dbName tsName dsNum instance' ,
'timestamp icType start_Rba dsName pit_Rba'
mDb =tkrIniT(m, 'db' y'Database', 'name')
call tkrIniK m, mDb, 'id iu', 'DBID'
mI = tkrIniT(m, 'i' y'Indexes', 'creator name' ,
, 'tbCreator, tbName, creator, name', , , 'vl')
call tkrIniK m, mI, 't i', 'tbCreator tbName'
call tkrIniK m, mI, 'vl u', 'creator name tbCreator tbName'
call tkrIniK m, mI, 'db1 iu', 'dbName indexSpace'
mIK= tkrIniT(m, 'ik' ,
'sysibm.sysIndexes ik' ,
'left join sysibm.sysKeys ikK' ,
'on ikK.ixCreator = ik.creator' ,
'and ikK.ixName=ik.name' ,
'left join sysibm.sysColumns ikC' ,
'on ikC.tbCreator = ik.tbCreator' ,
'and ikC.tbName = ik.tbName' ,
'and ikC.colNo = ikK.colNo' ,
, 'creator name ikK.colSeq' ,
, 'ik.tbCreator, ik.tbName, ik.creator' ,
|| ', ik.name, ikK.colSeq', , 'sqlCatIxKeys','vl')
call tkrIniK m, mIK, 'vl u', 'creator name colName ',
'tbCreator tbName'
call tkrIniT m, 'ip' y'indexPart', 'ixCreator ixName partition' ,
, , , ,1
mPk =tkrIniT(m, 'pk' y'Package', 'location collid name conToken' ,
, 'location, collid, name, pcTimestamp desc',,,'vl')
call tkrIniK m, mPk, '1plus',
, 'location collid name contoken version type'
call tkrIniK m, mPk, 'vl',
, 'location collid name version'
mPkd=tkrIniT(m, 'pkd' y'PackDep',
, 'dLocation dCollid dName dConToken',,,,'vl')
call tkrIniK m, mPkd, 'b', 'bQualifier bName'
call tkrIniK m, mPkd, 'vl', 'dLocation dCollid dName' ,
'bQualifier bName'
mRc =tkrIniT(m, 'rc' 'oa1p.vqz005Recover', 'db ts pa',
,,,'sqlCatRec')
call tkrIniK m, mRc, '1plus', 'db ts pa fun recover',
'basPTT loadText unlTst unl punTst pun tb'
call tkrIniT m, 'ri' y'IndexSpaceStats' ,
, 'creator name partition' ,
, 'creator name instance partition' ,
, , 'sqlCatIxStats', 1
/* 'dbid isobid partition instance' , */
mRT= tkrIniT(m, 'rt' y'TableSpaceStats' ,
, 'dbId psId partition instance',
, 'dbName name instance partition' ,
, , 'sqlCatTSStats')
call tkrIniK m, mRT, '1plus', 'dbId psId partition instance' ,
'dbName name'
call tkrIniK m, mRT, 'nm u', 'dbName name partition instance'
mT = tkrIniT(m, 't' y'Tables', 'creator name',
, , "t.type not in ('A', 'V')", 'sqlCatTables', 1)
call tkrIniK m, mT, 'db i', 'dbName tsName'
call tkrIniK m, mT, '1plus', 'creator name dbName tsName'
mTg =tkrIniT(m, 'tg' y'Triggers', 'schema name seqno',
, 'tbOwner, tbName, schema, name',,, 1)
call tkrIniK m, mTg, 'tb', 'tbOwner tbName'
call tkrIniT m, 'tp' y'TablePart', 'dbName tsName partition'
mTs =tkrIniT(m, 'ts' y'TableSpace', 'dbName name')
call tkrIniK m, mTs, 'id', 'dbId psId'
call tkrIniT m, 'v' y'Tables', 'creator name',, "v.type = 'V'",,1
mVD =tkrIniT(m, 'vd' y'ViewDep', 'dCreator dName',,,,'vl')
call tkrIniK m, mVd, 'b', 'bCreator bName'
call tkrIniK m, mVd, 'vl', 'dCreator dName bCreator bName'
call trkIniR m, 'c', 'v t'
call trkIniR m, 'co', 'ts tp rt.nm rc'
p0sql = '(SelecT smallInt(0) p FroM sysibm.sysDummy1' ,
'union all select smallInt(32767)p FroM sysibm.sysDummy1)p0'
r1 = tkrRel(m, 'co-tp')
m.r1.rig.sql1 = '(co.dbName, co.tsName, co.dsNum)' ,
'in (select tp.dbName, tp.tsName' ,
', min(tp.partition, p0.p)' ,
'from sysibm.sysTablePart tp,' p0Sql 'where'
r2 = tkrRel(m, 'co-rt')
m.r2.rig.sql1 = '(co.dbName, co.tsName, co.dsNum, co.instance)' ,
'in (select rt.dbName, rt.name' ,
', min(rt.partition, p0.p), rt.instance' ,
'from sysibm.sysTablespaceStats rt,' p0Sql 'where'
call trkIniR m, 'db', 'ts t.db tp rc rt co i.db1'
call trkIniR m, 'i.t', 't'
call trkIniR m, 'i', 'ik ip'
call trkIniR m, 'pk', 'pkd'
call trkIniR m, 'pkd.b', 'i', "pkd.bType in ('I')"
call trkIniR m, 'pkd.b', 't v',
, "pkd.bType in ('A', 'G', 'M', 'S', 'T', 'V')"
call trkIniR m, 'pkd.b', 'ts', "pkd.bType in ('P', 'R')"
call trkIniR m, 'rc', 'tp'
call trkIniR m, 'ri', 'i ip'
call trkIniR m, 'rt', 'ts.id'
call trkIniR m, 'rt.nm', 'tp rc'
call trkIniR m, 'tg.tb', 'v t'
call trkIniR m, 'ts', 't.db tp rc'
call trkIniR m, 'vd.b', 't', "vd.bType in ('G', 'M', 'T', 'V')"
call trkIniR m, 'vd', 'v', "vd.dType in ('V', 'M')"
m.m.pathBad = '1c 1co 1db 1tg pkd|pk vd|v pkd-i-t vkd-i-t'
m.m.numeric = 'PARTITION DBID INSTANCE PSID ISOBID DSNUM'
m.m.hex = 'CONTOKEN'
return
endProcedure tkrIniDb2Cat
tkrIniT: procedure expose m.
parse arg m, ty tb, cols, ord, wh, eFun, vl
mt = m'.t.'ty
if symbol('m.mt') == 'VAR' then
call err 'duplicate table' ty tb ord 'old' mt'->'m.mt
m.mt = 'table'
m.mt.alias = ty
m.mt.table = if(words(tb) == 1, tb ty, tb)
m.mt.uKeys = ''
m.mt.oKeys = ''
m.mt.rels = ''
m.mt.pKey = tkrIniK(m, mt, '1 iu', cols)
m.mt.vlKey = ''
if vl \== '' then
m.mt.vlKey = m'.k.'ty'.'vl
if ord == '' then
m.mt.order = mCat(m.mt.pKey, '%qn, %s')
else if pos(',', ord) < 1 & pos('.', ord) < 1 then
m.mt.order = ty'.'repAll(space(ord, 1), ' ', ',' ty'.')
else
m.mt.order = ord
m.mt.cond = wh || copies(' and', wh \== '')
m.mt.editFun = eFun
return mt
endProcedure tkrIniT
tkrIniK: procedure expose m.
parse arg m, tb, nm oo, cols
if pos(':', cols) > 0 | pos(',', cols) > 0 then
call err 'deimplemented iiKey:' cols
mk = m'.k.'m.tb.alias'.'nm
if symbol('m.mk') == 'VAR' then
call err 'duplicate key' tb nm 'old' mk'->'m.mk
m.mk = 'key'
al = m.tb.alias
m.mk.table = tb
m.mk.name = m.tb.alias'.'nm
m.mk.opt = oo
m.mk.0 = words(cols)
do cx=1 to m.mk.0
c1 = word(cols, cx)
dx = pos('.', c1)
if dx < 1 then do
m.mk.cx = al'.'c1
m.mk.cx.col = translate(c1)
end
else do
m.mk.cx = c1
m.mk.cx.col = translate(substr(c1, dx+1))
end
end
m.mk.colList = mCat(mk, '%qn, %s')
if pos('i', oo) > 0 then
m.tb.uKeys = strip(m.tb.uKeys mk)
else
m.tb.oKeys = strip(m.tb.oKeys mk)
return mk
endProcedure tkrIniK
trkIniR: procedure expose m.
parse arg m, le, aRi, leCo, riCo
le = tkrKey(m, le)
lTb = m.le.table
do rx=1 to words(aRi)
ri = tkrKey(m, word(aRi, rx))
rTb = m.ri.table
ky = m'.r.'m.lTb.alias'-'m.rTb.alias
if symbol('m.ky') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.ky
m.ky = 'relationShip'
m.ky.lef = le
m.ky.lef.sql1 = ''
m.ky.lef.cond = leCo || copies(' and', leCo \== '')
m.lTb.rels = m.lTb.rels ky
m.ky.rig = ri
m.ky.rig.cond = riCo || copies(' and', riCo \== '')
m.ky.rig.sql1 = ''
m.rTb.rels = m.rTb.rels ky
lr = m'.T2T.'m.lTb.alias'.'m.rTb.alias
if symbol('m.lr') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.lr
rl = m'.T2T.'m.rTb.alias'.'m.lTb.alias
if symbol('m.rl') == 'VAR' then
call err 'duplicate inverse relationShip' ky 'old' m.rl
m.lr = ky
end
return ky
endProcedure trkIniR
tkrKey: procedure expose m.
parse arg m, key
if m == '' then
m = tkr
dx = pos('.', key)
if dx < 1 then do
mt = m'.t.'key
if m.mt == 'table' then
return m.mt.pKey
ee = 'not a table' key':' mt'->'m.mt
end
dx = pos('.', key, dx+1)
if dx < 1 then do
mk = m'.k.'key
if m.mk == 'key' then
return mk
ee = 'not a key' key', mk' mk'->'m.mk
end
if m.key == 'key' then
return key
ee = 'not a key' key'-->'m.key
if arg() >= 3 then
return arg(3)
call err ee
endProcedure tkrKey
tkrRel: procedure expose m.
parse arg m, key
if m == '' then
m = tkr
if m.key == 'relationShip' then
return key
mr = m'.r.'key
if m.mr == 'relationShip' then
return mr
call err 'not a relationship' key'-->'m.key',' m.mr
endProcedure tkrRel
return mr
getInfo: procedure expose m.
parse arg m
if 0 then do /* debug variable in pool ???? */
ll = 'rcqMCase subSys funcName' ,
'hTable relation hEntity hUser entQual user2 entVers' ,
'objType objName qual'
do lx=1 to words(ll)
vv = word(ll, lx)
x = value(vv, 'valueBefore')
call adrIsp 'vget ('vv') asis', '*'
say '?? vget rc='rc',' vv'='value(vv)
end
end
call adrIsp 'vget (subsys rcqmcase funcName' ,
' htable relation hEntity' ,
'hUser entQual user2 entVers entVers2' ,
'objtype qual objname) shared'
m.m.dbSy = subsys
m.m.qmCase = rcQmCase
m.m.func = funcName
m.m.hTb = hTable
m.m.hOp = relation
m.m.hNm = hEntity
m.m.hCr = hUser
m.m.hQu = entQual
m.m.hGr = user2
m.m.hPkVers = entVers
m.m.hRoVers = entVers2
m.m.lTb = objType
m.m.lqu = qual
m.m.lNm = objName
call anaScreen m
m.m.lTb = translate(m.m.lTb, m.mAlfLc, m.malfUc)
m.m.hTb = translate(m.m.hTb, m.mAlfLc, m.malfUc)
m.m.hOp = translate(m.m.hOp, m.mAlfLc, m.malfUc)
if 0 then do
ww = screen curPos curLine curWord lineF lines ,
dbSy lTb lQu lNm func hTb hOp wh hNm hCr hQu hGr
do wx=1 to words(ww)
w1 = word(ww, wx)
if wx <= 11 then
say left(w1, 10) m.m.w1'.'
else
say left(w1, 10) m.m.w1.lb'='m.m.w1'.'
end
end
return
endProcedure getInfo
anaScreen: procedure expose m.
parse arg m
call adrIsp 'VGET (' zScreen zScreenW zScreenC zScreenI ')'
zScreenW = 80 /* breite Screens sind doch nicht so breit????*/
m.m.screen = zScreen
lx = zScreenC - ((zScreenC)//zScreenW) + 1
m.m.curPos = zScreenC || 'L' || ((zScreenC)%zScreenW+1) ,
|| 'C' || ((zScreenC)//zScreenW+1)
m.m.curLine = substr(zScreenI, lx, zScreenW)
sep = ' '
do wx=zScreenC+1 to lx+zScreenW-2 ,
while pos(substr(zScreenI, wx, 1), sep) > 0
end
do wx=wx by -1 to lx+1 ,
while pos(substr(zScreenI, wx-1, 1), sep) = 0
end
do wy=wx to lx+zScreenW-2 ,
while pos(substr(zScreenI, wy, 1), sep) = 0
end
m.m.curWord = substr(zScreenI, wx, wy-wx)
call anaHLine m, substr(zScreenI, 1+3*zScreenW, zScreenW),
, hTb, hOp, wh
call anaHLine m, substr(zScreenI, 1+4*zScreenW, zScreenW), hNm, hCr
call anaHLine m, substr(zScreenI, 1+5*zScreenW, zScreenW), hQu, hGr
l = substr(zScreenI, 6*zScreenW+1, zScreenW)
scx = 6
if word(l, 1) == 'Version' then
l = substr(zScreenI, ass('scx', 7)*zScreenW+1, zScreenW)
lx = lastPos('LINE', l)
isFrame = lx < 1
if isFrame then
lx = lastPos('FRAME', l)
if lx < 1 then
call err 'bad line of clause:' l
l = substr(l, lx, zScreenW-lx-1)
if word(l, 3) \== 'OF' then
call err 'bad line of clause:' l
m.m.lineF = word(l, 2)
m.m.lines = word(l, 4)
scx = scx + 1
tbOp = translate(m.m.hTb':'m.m.hOp, m.mAlfLc, m.mAlfUc)
if tbOp = 't:c' | tbOp = 't:tg' | tbOp = 'v:c' then do
m.m.lPaNm = m.m.hNm
return
end
else if tbOp = 'i:c' then do
m.m.lPaNm = m.m.hNm
m.m.lQu = m.m.hCr
return
end
else if tbOp = 'ts:pl' then
jj = 'tp PART'
else if tbOp = 'ts:d' then
jj = 'tp PART'
else if tbOp = 'i:pl' then
jj = 'ip PART'
else if tbOp = 'i:d' then
jj = 'ip PART'
else if translate(m.m.lTb) == 'PK' then
jj = 'pk COLLECTION CONTOKEN'
else
return
m.m.lTb = word(jj, 1)
if \ isFrame then do
tiLi = translate(substr(zScreenI, 1+scX*zScreenW, zScreenW),
, ' ', '00'x)
if word(tiLi, 1) <> 'CMD' then
call err 'CMD not found on line' scx':'tiLi
do sx = 1+(scX+1) * zScreenW by zScreenW to length(zScreenI)
if substr(zScreenI, sx, 8) \= '' then
leave
end
cuLi = translate(substr(zScreenI, sx, zScreenW), ' ', '00'x)
cmd = translate(strip(substr(cuLi, 2, 8)))
if cmd \= m.m.func then
call err 'fun' m.m.func '<> cmd' cmd (sx%zScreenW)':' cuLi
if m.m.lTb = 'pk' then do
m.m.collection = lineFldOA('COLLEC', tiLi, cuLi)
m.m.contoken = lineFldOA('CONTOK', tiLi, cuLi)
m.m.version = lineFldOA('VERSI', tiLi, cuLi)
if length(m.m.version) > 18 then
m.m.version = m.m.version'%'
end
else do
do jx = 2 to words(jj)
f1 = word(jj, jx)
m.m.f1 = lineFld(f1, tiLi, cuLi)
end
end
end
else do
do sx = 1+(scX) * zScreenW by zScreenW to length(zScreenI)
if substr(zScreenI, sx, 6) == ' CMD: ' then
leave
end
cuLi = translate(substr(zScreenI, sx, zScreenW), ' ', '00'x)
if word(cuLi, 1) \== 'CMD:' then
call err ' CMD: not found'
cmd = translate(word(cuLi, 2))
if cmd \= m.m.func then
call err 'fun' m.m.func '<> cmd' cmd (sx%zScreenW)':' cuLi
needed = left(' 23456789ABCDEFG', words(jj), 'x')
do sx = sx + zScreenW by zScreenW to length(zScreenI) ,
while needed <> ''
do jx = 2 to words(jj)
f1 = word(jj, jx)
if abbrev(strip(substr(zScreenI, sx+1, 12)), f1) then do
cuLi = substr(zScreenI, sx, zScreenW)
cx = pos(':', cuLi)
if cx < 10 then
call err 'no or bad : in' cuLi
if substr(needed, jx, 1) == ' ' then
call err 'duplicate' f1
else
needed = overlay(' ', needed, jx)
m.m.f1 = word(substr(cuLi, cx+1, zScreenW), 1)
end
end
end
if needed <> '' then
call err 'still fields needed' needed 'jj:' jj
end
return
endProcedure anaScreen
lineFld: procedure expose m.
parse arg f1, tiLi, cuLi
wx = wordPos(f1, tiLi)
if wx < 1 then
call err f1 'not in title' tiLi
bx = wordIndex(tiLi, wx)
ex = wordIndex(tiLi, wx+1)
if ex < 1 then
return strip(substr(cuLi, bx))
else
return strip(substr(cuLi, bx, ex-bx))
endProcedure lineFld
lineFldOA: procedure expose m.
parse arg abb, tiLi, cuLi
cx = pos(' 'abb, tiLi)
if cx < 1 then
return '*'
return lineFld(word(substr(tiLi, cx+1), 1), tiLi, cuLi)
endProcedure lineFldOA
anaHLine: procedure expose m.
parse arg m, li, f1, f2, f3
if substr(li, 14, 4) \== '===>' then
call err 'bad headerline1' li
m.m.f1.lb = strip(substr(li, 2, 12))
if m.m.f1 <> strip(substr(li, 19, 20)) then
call err f1 m.m.f1.lb':' m.m.f1 '<>' strip(substr(li, 19, 20))
if substr(li, 51, 4) \== '===>' then
call err 'bad headerline2' li
m.m.f2.lb = strip(substr(li, 43, 7))
if f3 == '' then
vv = strip(substr(li, 56, 20))
else
vv = strip(substr(li, 56, 2))
if m.m.f2 <> vv then
call err f2 m.m.f2.lb':' m.m.f2 '<>' vv
if f3 \== '' then do
if substr(li, 67, 2) \== '=>' then
call err 'bad headerline3' li
m.m.f3.lb = strip(substr(li, 61, 6))
if f3 = 'WH' then
m.m.f3 = strip(substr(li, 70, 10))
else if m.m.f3 <> strip(substr(li, 70, 10)) then
call err f3 m.m.f3.lb':' m.m.f3 '<>' strip(substr(li,70,10))
end
/* if f3 == '' then
say f1 m.m.f1.lb'='m.m.f1',' f2 m.m.f2.lb'='m.m.f2'|'
else
say f1 m.m.f1.lb'='m.m.f1',' f2 m.m.f2.lb'='m.m.f2',' ,
f3 m.m.f3.lb'='m.m.f3'|'
*/ return
endProcedure anaHLine
anaEdit: procedure expose m.
parse arg m, all
m.m.rz = sysvar(sysnode)
m.m.user = userid()
call adrIsp 'VGET (zScreen )'
m.m.screen = zScreen
call adrEdit "(cL cC) = cursor"
m.m.cursor = cL
call adrEdit "(lxLa) = lineNum .zl"
sq = ''
m.m.sql.0 = 0
m.m.path = ''
m.m.dbSy = ''
do lx=lxLa by -1 to 1
call adrEdit "(li) = line" lx
li = strip(li)
if word(li, 1) = 'order' then
m.m.sqlOrd = li
else if word(li, 1) = 'path:' then
m.m.path = subWord(li, 2)
else if word(li, 1) = 'dbSys:' then do
m.m.dbSy = subWord(li, 2)
leave
end
else do
sq = li sq
if word(li, 1) = 'from' then do
call mAdd m'.SQL', strip(sq)
sq = ''
end
end
end
m.m.sqlSta = sq
if lx < 1 | m.m.path == '' | m.m.dbSy == '' then
call err 'path:' m.m.path 'or dbSys' m.m.dbSy 'not found'
/* if m.m.sql.0 <> words(m.m.path) then
call err m.m.sql.0 'from clauses, but path' m.m.path */
tb1 = tkrTable(, word(m.m.path, 1), ,'')
if '' == tb1 then
call err 'path1 not table' m.m.path
if \ all then
call anaList m, tb1, all
pf3 = 'PF3 = zurück zu rcQuery'
laMa = 'cx'
do lx=1 to min(lxLa, 3)
call adrEdit '(li) = line' lx
if word(li, 1) \== '*' | pos('help', li) < 1 ,
| wordPos('PF3', li) < 1 then
iterate
li = strip(substr(strip(li), 2))
laMa = word(li, 1)
if pos('?', laMa) > 0 then
laMa = left(laMa, pos('?', laMa)-1)
cx = pos('PF3', li)
cy = pos(',', li, cx)
if cy > cx then
pf3 = substr(li, cy, cy-cx)
else
pf3 = strip(substr(li, cx))
leave
end
if \ abbrev(translate(laMa), 'R') then
laMa = laMa word(m.m.path, 1)
m.m.help = ' *' m.cmd '? = help,' ,
'UNDO = zurück zu' laMa',' pf3
return
endProcedure anaEdit
uxEditMacro: procedure expose m.
parse arg m, parms, all
call anaEdit m, 1
l = m'.LST'
m.l.0 = 0
call anaList m, tkrTable(, word(m.m.path, 1)), all
b = jBuf()
call pipe '+F', b
call genJob m, l, t1, parms
call pipe '-'
call adrEdit 'delete .zf .zl'
call adrEdit 'reset'
do bx=1 to m.b.buf.0
li = m.b.buf.bx
call adrEdit 'line_after .zl = (li)'
end
hh = m.m.help
call adrEdit 'line_before .zf = infoLine (hh)'
call adrEdit 'locate 1'
call adrEdit 'left max'
/*call adrEdit 'up max' */
return 1
endProcedure uxEditMacro
anaList: procedure expose m.
parse arg m, kq, all
l = m'.LST'
tb = tkrTable(, kq, , '')
if tb == '' then do
ky = tkrKey(, kq)
end
else do
al = m.tb.alias
ky = tkrKey( , al'.1plus', '')
if ky == '' then do
ky = tkrKey( , al'.db', '')
if ky == '' then
ky = m.tb.pKey
end
end
ky = tkrKey(,ky) /* check its a valid ky */
tb = m.ky.table
m.l.key = ky
m.l.alias = m.tb.alias
call adrEdit 'cursor = .zf'
do forever /* search title line */
if 0 <> adrEdit('find - 1 40', 0 4) then
call err 'could not find title: find first - 1 40'
call adrEdit '(ex cx) = cursor'
call adrEdit '(ti) = line' ex
tiSx = pos(' ', ti)
if tiSx > 0 & tiSx > pos('-', ti) then
leave
end
m.l.0 = 0
if abbrev(ti, '--- row 1 ---') then do /* c1 display */
if all then do
call adrEdit 'cursor = 1 0'
do rx=1 while adrEdit("find '--- row ' 1", 0 4) = 0
call adrEdit "(ex cx) = cursor"
call adrEdit "(li) = line .zCsr"
call anaListRow l, ky, ex
end
end
else
call anaListRow l, ky, ex
end
else do /* cx display */
t1 = strip(ti, 't')
do vx=length(t1) by -1 to 1 while substr(t1, vx, 1) == '-'
end
if vx < 10 then
call err 'no labels found in title' t1
vt = left(t1, vx)
vx = lastPos('-', vt) + 1
sep = sqlCatTbVLsep()
vt = repAll(substr(vt, vx), sep, ' ')
vl = words(vt)
call adrEdit "find last '"left(t1, 40)"' 1"
call adrEdit "(ty cy) = cursor"
ey = ty
if ey <= ex then
call err 'no trailer line found:' left(t1, 40)
if \ all then do
if m.m.cursor <= ex | m.m.cursor >= ey then
call err 'i}cursor line' m.m.cursor ,
'not between header' ex 'and trailer' ey 'lines'
ex = m.m.cursor - 1
ey = m.m.cursor + 1
end
cx = 0
do ly=ty+1
call adrEdit '(li) = line' ly
if left(li, 70) = '' | 'DBSYS:' == translate(word(li, 1)) then
leave
cx = cx + 1
m.m.cyc.cx = translate(strip(li, 't'))
end
m.m.cyc.0 = cx
if cx < 1 then
call err 'no cycle trailer lines found'
do tx = 1 to m.ky.0
co = m.ky.tx.col
f.tx.fld = tx
if wordPos(co, vt) > 0 then do
f.tx.pos = - wordPos(co, vt)
end
else do
do cy=1 to cx
wx = wordPos(co, m.m.cyc.cy)
if wx > 0 then
leave
end
if wx < 1 then
call err 'column' co 'not found in cycle trailer'
wx = wordIndex(m.m.cyc.cy, wx)
cz = 1 + (cy // cx)
lz = substr(m.m.cyc.cz, wx)
wy = wordIndex(lz, 2 - abbrev(lz, ' ')) - 1
if wy < 1 then
wy = 1 + length(t1) - wx
f.tx.pos = wx
f.tx.len = wy
end
end
lx = 0
do ex=ex+1 to ey-1 /* each cx line */
call adrEdit '(li) = line' ex
li = strip(li, 't')
ql = substr(li, vx)
qy=1
do qx=1 to vl-1
qz = pos(sep, ql, qy)
if qz = 0 then
call err 'bad ql' ql 'for' vt
ql.qx = substr(ql, qy, qz-qy)
qy=qz+length(sep)
end
ql.vl = substr(ql, qy)
lx = lx + 1
do tx = 1 to m.ky.0
if f.tx.pos == '' then
m.l.lx.tx = ''
else if f.tx.pos > 0 then
m.l.lx.tx = strip(substr(li, f.tx.pos, f.tx.len))
else do
qx = - f.tx.pos
m.l.lx.tx = ql.qx
end
m.l.lx.99 = ''
end
m.l.0 = lx
end /* each cx line */
end /* cx display */
return
endProcedure anaList
anaListRow: procedure expose m.
parse arg l, ky, ex
lx = m.l.0 + 1
needed = left('1234565789ABCDEFGHIJKLMN', m.ky.0, 'x')
do ex=ex+1 until needed = ''
call adrEdit "(li) = line" ex
li = strip(li, 't')
if abbrev(li, '--- row ') | abbrev(li, '--- end of ') then
leave
liCo = translate(word(li, words(left(li, 30))))
do tx=1 to m.ky.0
if liCo = m.ky.tx.col then do
needed = overlay(' ', needed, tx)
if datatype(substr(li, 31, 12), 'n') ,
& datatype(substr(li, 43), 'n') then
m.l.lx.tx = strip(substr(li, 43))
else
m.l.lx.tx = substr(li, 31)
end
end
end
if needed <> '' then
call err 'needed' needed "<> '', tb" tb 'line' ex
m.l.lx.99 = ''
m.l.0 = lx
return
endProcedure anaListRow
listDef: procedure expose m.
parse arg l, list
if m.l.lp.alias == '' then
call err 'listDef with empty lp.alias, type='m.l.type
tParts = 0 < wordPos('tp', list) + wordPos('ip', list)
tObjs = 0 < wordPos('ts', list) + wordPos('i', list)
if m.l.lp.alias = 'tp' then do
if tParts then do
if m.l.alias == 'rc' then do
if m.l.tpNo.0 <> 0 then do
call out ' -- ignoring objects because of fun'
do lx=1 to m.l.tpNo.0
call out ' --' m.l.tpNo.lx
end
end
call listDef1 l'.TPRC', tpRc, 'TABLESPACE', 'PARTLEVEL'
if m.l.tpRc.0 = 0 then
call out ' INCLUDE TABLESPACE DOESNOT.EXIST*'
end
call listDef1 l'.LP', tp, 'TABLESPACE', 'PARTLEVEL'
if wordPos('ip', list) > 0 then
call out ' LISTDEF IPLIST INCLUDE INDEXSPACES' ,
'LIST TPLIST'
if wordPos('ip', list) > 0 m..tpRc.0 <> 0 then
call out ' LISTDEF IPRCLIST INCLUDE INDEXSPACES' ,
'LIST TPRCLIST'
end
if tObjs then do
call listDef1 l'.LO', ts, 'TABLESPACE'
if wordPos('i', list) > 0 then
call out ' LISTDEF ILIST INCLUDE INDEXSPACES' ,
'LIST TPLIST'
end
end
else if m.l.lp.alias == 'ip' then do
if tParts then do
call listDef1 l'.LP', ip, 'INDEX', 'PARTLEVEL'
if wordPos('tp', list) > 0 then
call out ' LISTDEF TPLIST INCLUDE TABLESPACES' ,
'LIST IPLIST'
end
if tObjs then do
call listDef1 l'.LO', i, 'INDEX'
if wordPos('ts', list) > 0 then
call out ' LISTDEF TSLIST INCLUDE TABLESPACES' ,
'LIST ILIST'
end
end
else
call err 'listDef no objs found'
return
endProcedure listDef
listdef1: procedure expose m.
parse arg l, ld, sp, pa
call out ' LISTDEF' ld'LIST'
t2 = ''
do lx=1 to m.l.0
if pa \== '' then
t2 = 'PARTLEVEL' m.l.lx.3
call out ' INCLUDE' sp m.l.lx.1'.'m.l.lx.2 t2
end
return
endProcedure listDef1
listExp: procedure expose m.
parse arg l
m.l.lp.alias = ''
m.l.lp.0 = 0
m.l.lo.0 = 0
tF = m.l.alias
if wordPos(tF, 'co tp rc') > 0 then
ii = 'tp 1 2 3'
else if tF == 'rt' then
ii = 'tp 5 6 3'
else if tF == 'ts' then
ii = 'tp 1 2 99'
else if tF == 't' then
ii = 'tp 3 4 99'
else if wordPos(tF, 'is ip ri') > 0 then
ii = 'ip 1 2 3'
else if wordPos(tF, 'i ik') > 0 then
ii = 'ip 1 2 99'
else
return l
m.l.colInfo = ii
if tF == 't' then
m.l.colTb = 1 2
else
m.l.colTb = ''
parse var ii m.l.lp.alias f1 f2 f3
xp = 0
xo = 0
xR = 0
xL = 0
xN = 0
drop done.
do lx=1 to m.l.0
v1 = m.l.lx.f1
v2 = m.l.lx.f2
v3 = m.l.lx.f3
if done.v1.v2.v3 == 1 then
iterate
done.v1.v2.v3 = 1
xp = xp + 1
m.l.lp.xp.1 = v1
m.l.lp.xp.2 = v2
m.l.lp.xp.3 = v3
if tF = 'rc' then do
if translate(m.l.lx.4) = 'R' then do
xR = xR + 1
m.l.tpRc.xR.1 = v1
m.l.tpRc.xR.2 = v2
m.l.tpRc.xR.3 = v3
end
else if translate(m.l.lx.4) = 'L' then do
xL = xL + 1
m.l.tpLo.xL.1 = v1
m.l.tpLo.xL.2 = v2
m.l.tpLo.xL.3 = v3
end
else do
xN = xN + 1
m.l.tpNo.xN = v1'.'v2':'v3 'fun='m.l.lx.4
end
end
if done.v1.v2 == 1 then
iterate
done.v1.v2 = 1
xo = xo + 1
m.l.lo.xo.1 = v1
m.l.lo.xo.2 = v2
end
m.l.lp.0 = xp
m.l.lo.0 = xo
m.l.tpLo.0 = xL
m.l.tpNo.0 = xN
m.l.tpRc.0 = xR
m.l.lpRc.0 = xR
if tF = 'rc' then
m.l.lpRc = tpRc
else
m.l.lpRc = m.l.lp.alias
return l
endProcedure listExp
listSelect: procedure expose m.
parse arg m, l, o, ky, pa
tb = m.ky.table
al = m.tb.alias
if m.l.alias == al then do
do kx=1 to m.ky.0
c1 = m.ky.kx.col
do ox=1 to m.l.0
m.o.ox.c1 = m.l.ox.kx
end
end
m.o.0 = m.l.0
return o
end
sq = 'select' m.ky.colList tkrTable(, tb, 'f') ,
tkrWhere(, al pa m.l.alias':' ,
list2where(l, tkrKey(, m.l.alias'.1')))
call sqlconnect m.m.dbSy
call sql2St sq, o
call sqlDisconnect
return o
endProcedure listSelect
list2where: procedure expose m.
parse arg l, aKey
tb = m.aKey.table
al = m.tb.alias
drop done.
done = ''
do lx=1 to m.l.0
k2 = ''
do tx=1 to m.aKey.0-1
k2 = k2'.'m.l.lx.tx
end
k2 = substr(k2, 2)
ty = m.aKey.0
ky = k2'.'m.l.lx.ty
vy = tkrValue( , , m.aKey.ty, m.l.lx.ty)
if done.ky == 1 then
iterate
done.ky = 1
dx = wordPos(k2, done)
if dx > 0 then do
done.dx = done.dx"," vy
end
else do
done = done k2
dx = wordPos(k2, done)
s1 = ''
do tx=1 to m.aKey.0-1
s1 = s1 tkrPred( , , m.aKey.tx, m.l.lx.tx)
end
done.dx = substr(s1, 6) 'and' m.aKey.ty "in ("vy
end
end
wh = ''
do dx = 1 to words(done)
wh = wh 'or ('done.dx'))'
end
return '('substr(wh, 5)')'
endProcedure list2where
genJob: procedure expose m.
parse arg m, l, ty, parms
m.m.rand = right(time(), 2) // 20
m.m.jn = m.m.user || substr(m.mAlfUC, m.m.rand+7, 1)
call out "//"m.m.jn "JOB (CP00,KE50),'DB2" parms"',"
call out "// TIME=1440,REGION=0M,SCHENV=DB2ALL" ,
|| ",CLASS=M1,"
call out "// MSGCLASS=T,NOTIFY=&SYSUID"
call out "//*"
call out "//* ux utility generator" parms
call out "//* who" m.m.rz m.m.dbSy m.m.user m.m.screen
call out "//* " translate(date('E'), '.', '/') time() ,
m.m.jn
call out "//*"
inStep = ''
m.m.stepNo = 0
pa2 = ''
uts = 'co=COPY re=REORG rb=REBIND rb=RBIND rc=RECOVER rc=RCOVER' ,
'ru=RUNSTATS bu=REBUILD bu=BUILD un=UNLOAD' ,
'ld=LOADDUMMY ld=LOADUMMY ld=LDUMMY ld=DUMMY',
'cd=CDATA cd=CHECKDATA',
'ce=CEXCEPTIONTABLES ce=CHECKEXCEPTIONTABLES',
'ce=CHECKDATAEXCEPTIONTABLES' ,
'ci=CINDEX ci=CHECKINDEX'
do ux=1 to words(parms)
cx = pos('='translate(word(parms, ux)), uts)
if cx <= 2 then
call err 'bad utility parm' word(parms, ux) 'in' parms, 'S'
pa2 = pa2 substr(uts, cx-2, 2)
end
m.m.statsProf = wordPos(sysvar(sysnode), 'RZX') > 0
if m.m.statsProf & pos('ru', pa2) < 1 then do
rx = max(lastPos('re', pa2), lastPos('ld', pa2))
if rx > 0 then
pa2 = insert(' ru', pa2, rx+1)
end
lst = ''
if wordPos('co', pa2) > 0 | wordPos('re', pa2) > 0 then
lst = lst 'tp'
if wordPos('rc', pa2) > 0 then
lst = lst 'tp' copies('tpRc tpLo', m.l.alias = 'rc')
if wordPos('ru', pa2) > 0 | wordPos('un', pa2) > 0 then
lst = lst 'ts'
if wordPos('bu', pa2) > 0 | wordPos('ci', pa2) > 0 then
lst = lst 'ip'
call listExp l
lstSuf = 'LIST'
if wordPos('rc', pa2) > 0 then
if m.l.alias <> 'rc' then
call warnXDocs m, l
m.m.prodOut = m.m.rz = 'RZ2' & (wordPos('rc', pa2) > 0 ,
| wordPos('ld', pa2) > 0 | wordPos('bu', pa2) > 0)
m.m.prodMark = left(copies('?', m.m.prodOut), 1)
if m.m.prodOut then do
call out left("//* >>> Attention possible production outage ",
, 80, '<')
call out "//* check utilities"
call out "//* remove '?' before utilities only if ok"
call out "//*"
end
do ux=1 to words(pa2)
u1 = word(pa2, ux)
if wordPos(u1, 'bu co ld re rc ru un cd ce ci') > 0 then do
if inStep \== 'ut' then do
inStep = 'ut'
call genUtil m
if lst \== '' then
call listdef l, lst
end
if u1 == 'bu' then
call genBuild m, lstSuf
else if u1 == 'cd' | u1 = 'ce' then
call genCheckData m, l, u1
else if u1 == 'ci' then
call genCheckIndex m
else if u1 == 'co' then
call genCopy m, lstSuf
else if u1 == 'ld' then
call genLoadDummy m, l'.LP',
, listSelect(m, l, tbPa, tkrKey(, 't.1plus'))
else if u1 == 'rc' then do
if m.l.alias <> 'rc' then do
call genRecover m, l, lstSuf
end
else do
if m.l.tpLo.0 <> 0 then
call genRecLoad m, l
lstSuf = 'RCLIST'
if m.l.tpRc.0 <> 0 then
call genRecover m, l, lstSuf
end
end
else if u1 == 're' then
call genReorg m
else if u1 == 'ru' then
call genRunstats m
else if u1 == 'un' then
call genUnload m, l
else
call err 'implement util' u1
end
else if u1 \== 'rb' then do
call err 'implement util' u1
end
else do
pkl = m'.pkl'
call listSelect m, l, pkl, tkrKey(, 'pk.1plus'), 'ts'
call genDsn m
inStep = 'dsn'
do px=1 to m.pkl.0
if m.pkl.px.type = '' then
call out 'rebind package ('strip(m.pkl.px.collid) ,
|| '.'strip(m.pkl.px.name) ,
|| '.('strip(m.pkl.px.version)'))'
else if m.pkl.px.type = 'T' then
call out 'rebind trigger package(' ,
|| strip(m.pkl.px.collid)'.' ,
|| strip(m.pkl.px.name)')'
else
call err 'implement rebind of pk type' m.pkl.px.type
end
end
end
return
endProcedure genJob
genBuild: procedure expose m.
parse arg m, liSu
call out left('---- rebuild index ', 72, '-')
call out m.m.prodMark "REBUILD INDEX LIST IP"liSu
call out " SORTDEVT SYSDA"
call out " STATISTICS UPDATE ALL"
return
endProcedure genBuild
genCheckData: procedure expose m.
parse arg m, l, fu
if m.l.lp.alias <> 'tp' then
call err 'i}use checkData not from indexes'
call out left('---- checkData ', 72, '-')
call out " CHECK DATA"
do lx = 1 to m.l.lp.0
call out " TABLESPACE" m.l.lp.lx.1"."m.l.lp.lx.2 ,
if(m.l.lp.lx.3 \== "", "PART" m.l.lp.lx.3)
end
call out " SHRLEVEL REFERENCE"
call out " SCOPE ALL"
call out " EXCEPTIONS 0"
if fu == 'ce' then do
call out " FOR EXCEPTION"
uxDb = 'DB2$$$UX'
sq = ''
do lx = 1 to m.l.lo.0
if oldDb \== m.l.lo.lx.1 then do
oldDb = m.l.lo.lx.1
sq = sq")) or (t.dbName = '"oldDb"' and t.tsName in ("
end
else
sq = sq", "
sq = sq"'"m.l.lo.lx.2"'"
end
sq = "select t.creator, t.name, t.encoding_scheme, s.bPool",
"from sysibm.sysTables t" ,
"join sysibm.sysTableSpace s" ,
"on t.dbName = s.dbName and t.tsName = s.name" ,
"where t.type not in('A', 'V')" ,
"and ("substr(sq, 7)")))"
call sqlconnect m.m.dbSy
o = m'.tb'
call sql2St sq, o
call sqlExImm "set current sqlid = 'S100447'"
if sql2One("select name from sysibm.sysDatabase" ,
"where name = '"uxDb"'", 'uxDB', '') ,
\== uxDb then do
call sqlExImm "create database" uxDB ,
"BUFFERPOOL BP2 INDEXBP BP1 STOGROUP GSMS"
call sqlCommit
say 'db' uxDb 'created'
end
ts = sql2One("select value(max(name), '$$$00000')" ,
"from sysibm.sysTablespace where dbname = '"uxDb"'")
do ox=1 to m.o.0
if left(ts, 3) \== '$$$' | \ datatype(substr(ts, 4), 'n'),
then call err 'bad ts' ts
ts = left(ts, 3) || right('00000' || (1+substr(ts, 4)), 5)
call sqlExImm "create tablespace" ts "in" uxDB ,
"segsize 64 bufferpool" m.o.ox.bPool ,
"compress yes maxRows 255 ccsid",
if(m.o.ox.encoding_scheme=='E','EBCDIC','UNICODE')
cr = "$UX$"strip(m.o.ox.creator)"$"
tb = "$UX$"strip(m.o.ox.name)"$"
call out " IN " strip(m.o.ox.creator) ,
|| "."strip(m.o.ox.name)
call out " USE" cr"."tb
do forever
sc = sqlExImm("create table" cr"."tb ,
"like" m.o.ox.creator"."m.o.ox.name ,
"including identity" ,
"in" uxDb"."ts, -601)
if sc = 0 then do
say 'created table' cr'.'tb 'in' uxDb'.'ts
leave
end
oldTs = sql2one("select strip(dbName) || '.' ||" ,
"strip(tsName) from sysibm.sysTables",
"where creator = '"cr"' and name = '"tb"'")
say 'table' cr'.'tb 'already exists in' oldTs
if substr(ans, 2, 1) \== 'A' then do
say 'Use old table, Drop tableSpace, Exit?' ,
'(u/d/e +a for all)'
parse upper pull ans .
end
if abbrev(ans, 'U') then do
call sqlExImm "drop tableSpace" uxDb"."ts
say "dropped tableSpace" uxDb"."ts
leave
end
if \ abbrev(ans, 'D') then
call err 'table' cr'.'tb 'already exists in' oldTs
call sqlExImm "drop tableSpace" oldTs
say "dropped tableSpace" oldTs
call sqlCommit
end
call sqlCommit
end
call out " DELETE NO -- YES LOG YES"
call sqlDisconnect
end
call out " WORKDDN(TSYUTS, TSOUTS) ERRDDN TERRD"
call out " SORTDEVT DISK"
return
endProcedure genCheckData
genCheckIndex: procedure expose m.
parse arg m, l, fu
call out left('---- checkIndex ', 72, '-')
call out " CHECK INDEX LIST IPLIST"
call out " SHRLEVEL REFERENCE"
call out " SORTDEVT DISK"
return
endProcedure genCheckIndex
genCopy: procedure expose m.
parse arg m, liSu
call out left('---- copy ', 72, '-')
call out " COPY LIST TP"liSu "COPYDDN(TCOPYD)"
call out " FULL YES"
call out " PARALLEL"
call out " SHRLEVEL CHANGE"
return
endProcedure genCopy
genLoadDummy: procedure expose m.
parse arg m, lp, l
if m.lp.alias \== 'tp' then
call err 'loadDummy for' m.lp.alias
ts = ''
drop ts. tb.
do px=1 to m.lp.0
ky = strip(m.lp.px.1)'.'strip(m.lp.px.2)
if symbol('ts.ky') \== 'VAR' then do
ts.ky = ''
tb.ky = ''
ts = ts ky
end
if m.lp.px.3 <> '' then
ts.ky = overlay('p', ts.ky, m.lp.px.3)
kt =
end
do lx=1 to m.l.0
ky = strip(m.l.lx.dbName)'.'strip(m.l.lx.tsName)
kt = strip(m.l.lx.creator)'.'strip(m.l.lx.name)
if symbol('ts.ky') \== 'VAR' then
call err 'ts' ky 'for t' kt 'not in part list'
if wordPos(kt, tb.ky) < 1 then
tb.ky = tb.ky kt
end
rSp = " RESUME NO REPLACE COPYDDN(TCOPYS) INDDN INDUMMY"
do tx=1 to words(ts)
ky = word(ts, tx)
call out left('---- load dummy' ky, 72, '-')
if symbol('tb.ky') \== 'VAR' then
call err 'no table in ts' ky
call out m.m.prodMark "LOAD DATA LOG NO"
call out " WORKDDN(TSYUTS, TSOUTS) MAPDDN TMAPD"
call out " STATISTICS INDEX(ALL) REPORT NO UPDATE ALL"
ps = ts.ky
if ps = '' then do
call out rSp
do qx=1 to words(tb.ky)
call out " INTO TABLE" word(tb.ky, qx)
end
end
else do
t1 = strip(tb.ky)
if words(t1) <> 1 then
call err 'multiple tables' t1 'in partitioned TS'
do while ps <> ''
px = pos('p', ps)
ps = overlay(' ', ps, px)
call out " INTO TABLE" t1 'PART' px
call out rSp
end
end
end
return
endProcedure genLoadDummy
genRecover: procedure expose m.
parse arg m, l, liSu
minRba = 'FFFFFFFFFF'
maxRba = '00'
minPit = 'FFFFFFFFFF'
maxPit = '00'
dsn = ''
cDsn = 0
rDsn = '?.? DSNUM ?'
if m.l.alias == 'co' then do
ky = tkrKey(, 'co.1plus')
fty = wordPos('co.icType,', m.ky.colList',')
fRba = wordPos('co.start_Rba,', m.ky.colList',')
fPit = wordPos('co.pit_Rba,', m.ky.colList',')
fDsn = wordPos('co.dsName,', m.ky.colList',')
do lx=1 to m.l.0
if pos(left(m.l.lx.fTy, 1), 'FI') > 0 then do
cDsn = cDsn + 1
dsn = m.l.lx.fDsn
rDsn = m.l.lx.1'.'m.l.lx.2
if m.l.lx.3 <> '' then
rDsn = rDsn 'DSNUM' m.l.lx.3
end
if x2c(minRba) >> x2c(m.l.lx.fRba) then
minRba = m.l.lx.fRba
if x2c(maxRba) << x2c(m.l.lx.fRba) then
maxRba = m.l.lx.fRba
if m.l.lx.fPit \= '000000000000' then do
if x2c(minPit) >> x2c(m.l.lx.fPit) then
minPit = m.l.lx.fPit
if x2c(maxPit) << x2c(m.l.lx.fPit) then
maxPit = m.l.lx.fPit
end
end
end
call out left('---- recover ', 72, '-')
call out '-- Tipp: mit TSO LRSN logPoints umwandeln'
call out m.m.prodMark 'RECOVER LIST TP'liSu
call out ' PARALLEL'
if maxPit = '00' then nop
else if maxPit = minPit then
call out "-- TOLOGPOINT X'"maxPit"' -- pit_rba"
else do
call out "-- TOLOGPOINT X'"maxPit"' -- max pit_rba"
call out "-- TOLOGPOINT X'"minPit"' -- min pit_rba"
end
if maxPit \= '00' & maxRba = '00' then nop
else if maxRBA = minRBA then
call out "-- TOLOGPOINT X'"maxRBA"' -- start_rba"
else do
call out "-- TOLOGPOINT X'"maxRBA"' -- max start_rba"
call out "-- TOLOGPOINT X'"minRBA"' -- min start_rba"
end
call out '-- LOGONLY BACKOUT YES'
call out '-- RESTOREBEFORE' minRba
call out '-- TOLASTCOPY'
call out '-- TOLASTFULLCOPY'
call out '--RECOVER TABLESPACE' rDsn
call out '-- TOCOPY' dsn
if cDsn > 1 then
call out ' -- Achtung' cDsn 'copies|'
return
endProcedure genRecover
genRecLoad: procedure expose m.
parse arg m, l
if m.l.alias \== 'rc' then
call err 'genRecLoad ohne alias rc'
ky = tkrKey(, 'rc.1plus')
fFun = wordPos('rc.fun,' , m.ky.colList',')
fRec = wordPos('rc.recover,' , m.ky.colList',')
fbas = wordPos('rc.basPTT,' , m.ky.colList',')
fLoa = wordPos('rc.loadText,', m.ky.colList',')
fUts = wordPos('rc.unlTst,' , m.ky.colList',')
fUnl = wordPos('rc.unl,' , m.ky.colList',')
fPTs = wordPos('rc.punTst,' , m.ky.colList',')
fPun = wordPos('rc.pun,' , m.ky.colList',')
fTb = wordPos('rc.tb,' , m.ky.colList',')
/* m, mRc, '1plus', 'db ts pa recFun recover',
'basPTT load unlTst unl punTst pun tb'
*/
ty = 0
do forever
do tx=1 to m.l.0
if translate(m.l.tx.fFun) <> 'L' then
iterate
aTb = strip(m.l.tx.fTb)
if done.aTb <> 1 then
leave
end
if tx > m.l.0 then
leave
done.aTb = 1
ty = ty + 1
call out '-- templates for table' ty aTb
do lx=tx to m.l.0
if translate(m.l.lx.fFun) <> 'L' | aTb <> m.l.lx.fTb then
iterate
call out ' TEMPLATE T'ty'P'm.l.lx.3
call out " DSN('"strip(m.l.lx.fUnl)"')"
end
call out '-- loading table' ty aTb
call out m.m.prodMark 'LOAD DATA LOG NO'
call out ' STATISTICS INDEX(ALL) REPORT NO UPDATE ALL'
call out ' SORTKEYS SORTDEVT DISK'
call out ' WORKDDN(TSYUTD,TSOUTD)'
do lx=tx to m.l.0
if translate(m.l.lx.fFun) <> 'L' | aTb <> m.l.lx.fTb then
iterate
call out ' -- part ' m.l.lx.1'.'m.l.lx.2':'m.l.lx.3
call out ' -- recov?' m.l.lx.fRec m.l.lx.fBas
call out ' -- unloa?' m.l.lx.fLoa
call out ' -- unload' m.l.lx.fUnl m.l.lx.fUTs
call out ' -- punch ' m.l.lx.fPun m.l.lx.fPts
call out ' INTO TABLE' m.l.lx.fTb 'PART' m.l.lx.3
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)'
call out ' INDDN T'ty'P'm.l.lx.3
s = jOpen(scanUtilReset(ScanRead(file(m.l.lx.fPun))), '<')
if \ scanUtilInto(s) then
call scanErr s, 'no load into' m.l.lx.fPun
call out '--end utilInto' m.s.tb m.s.part
if m.s.tb <> m.l.lx.fTb then
call err 'punch tb' m.s.tb '<>' m.l.lx.fTb ,
'in' m.l.lx.fPun
call jClose s
end
end
return
endProcedure genRecLoad
warnXDocs: procedure expose m.
parse arg m, l
XDoc = ''
if m.l.lp.alias <> 'tp' then
call err 'lp.alias' m.l.lp.alias
do px=1 to m.l.lp.0 while XDoc == ''
db = m.l.lp.px.1
ts = m.l.lp.px.2
if db = 'XC01A1P' ,
& ( abbrev(ts, 'A200A') ,
| ts = 'A501A' | ts = 'A502A' ,
) then
XDoc = 'XC'
else if db = 'XR01A1P' then
XDoc = 'XR'
else if left(db, 2) = 'XB' then
XDoc = 'XB'
else if db = 'QZ01A1P' & ts = 'A004A' then
XDoc = 'qzTest'
end
if xDoc \== '' then do
call out left('//* >>> Attention:' XDoc ,
'Documents, besser aus CX RC recovern ', 80, '<')
call out '//*'
end
return
endProcedure warnXDocs
genReorg: procedure expose m.
parse arg m
call out left('---- reorg ', 72, '-')
call out ' REORG TABLESPACE LIST TPLIST'
call out ' LOG NO'
call out ' SORTDATA'
call out ' COPYDDN(TCOPYD)'
call out ' SHRLEVEL CHANGE'
/*
call out ' -- Achtung mapping table' ,
'zufällig gewählt|'
call out ' MAPPINGTABLE S100447.MAPTAB'm.m.rand2
if wordPos(sysvar(sysnode), 'RZ2 RR2') < 1 then
call out ' MAPPINGDATABASE QZMAPTB' ...
*/
call out ' DRAIN_WAIT 20'
call out ' RETRY 20 '
call out ' RETRY_DELAY 180'
call out ' MAXRO 20 '
call out ' DRAIN ALL'
call out ' LONGLOG CONTINUE'
call out ' DELAY 600'
call out ' TIMEOUT TERM'
call out ' UNLDDN TSRECD'
call out ' UNLOAD CONTINUE'
call out ' PUNCHDDN TPUNCH'
call out ' DISCARDDN TDISC'
call out ' SORTKEYS'
call out ' SORTDEVT DISK'
call out ' STATISTICS'
call out ' INDEX ALL KEYCARD '
call out ' UPDATE ALL'
return
endProcedure genCopy
genRunstats: procedure expose m.
parse arg m
call out left('---- runstats ', 72, '-')
call out " RUNSTATS TABLESPACE LIST TSLIST"
call out " SHRLEVEL CHANGE "
if m.m.statsProf then do
call out " TABLE USE PROFILE"
call out " TABLESAMPLE SYSTEM AUTO"
end
else do
call out " INDEX(ALL)"
end
return
endProcedure genRunstats
genUnload: procedure expose m.
parse arg m, l
if m.l.lp.alias <> 'tp' then
call err 'i}use unload not from indexes'
call out "TEMPLATE TREC -- UNLDDN fuer Unload"
call out " DSN('&SSID..&DB..&SN..P&PART..D&YE(3).&MO.&DA..REC')"
call out " DATACLAS(ENN35) MGMTCLAS(COM#A032)"
call out " SPACE TRK MAXPRIME 600"
call out "TEMPLATE TPUN -- PUNCHDDN fuer reorg unload"
call out " DSN('&SSID..&DB..&SN..P&PART..D&YE(3).&MO.&DA..PUN')"
call out " DATACLAS(NULL8) MGMTCLAS(COM#A032)"
call out " SPACE(1,10) TRK"
parse var m.l.colInfo . dbX tsX .
parse var m.l.colTb crX tbX .
do tx=1 to m.l.0
dbTs = m.l.tx.dbX'.'m.l.tx.tsX
crTb = m.l.tx.crX'.'m.l.tx.tbX
if done.dbTs.qq.crTb == 1 then
iterate
done.dbTs.qq.crTb = 1 then
call out "UNLOAD TABLESPACE" dbTs '-- PART 7:8'
call out "-- UNLOAD LIST TSLIST"
call out " -- FROM COPY" m.m.dbSy"."dbTs".P00001..."
call out " UNLDDN TREC PUNCHDDN TPUN EBCDIC NOPAD"
call out " SHRLEVEL CHANGE ISOLATION CS -- SKIP LOCKED DATA"
if crTs <> '.' then
call out " FROM TABLE" crTb
/* iterate
aTb = strip(m.l.tx.fTb)
if done.aTb <> 1 then
leave
*/ end
return
endProcedure genUnload
genUtil: procedure expose m.
parse arg m
m.m.stepNo = m.m.stepNo + 1
call out left("//STEP"m.m.stepNo , 10),
"EXEC PGM=DSNUTILB,TIME=1440,"
call out "// PARM=("m.m.dbSy",'"m.m.jn".UXUTIL'),"
call out "// REGION=0M"
call out "//SYSPRINT DD SYSOUT=*"
call out "//*YSPRINT DD DSN=DSN.JOBRUN."m.m.jn ,
|| ".STEP"m.m.stepNo".#DT#,"
j = left('//*', 15)
call out j"DISP=(NEW,CATLG,CATLG),MGMTCLAS=BAT#NW,DSNTYPE=LARGE,"
call out j"DCB=(RECFM=FB,LRECL=132,DSORG=PS),SPACE=(CYL,(1,1000))"
call out "//SYSUDUMP DD SYSOUT=*"
call out "//SYSTEMPL DD DISP=SHR,DSN="m.m.dbSy ,
|| ".DBAA.LISTDEF(TEMPL)"
call out "//UTPRINT DD SYSOUT=*"
call out "//RNPRIN01 DD SYSOUT=*"
call out "//STPRIN01 DD SYSOUT=*"
call out "//INDUMMY DD DUMMY"
call out "//SYSIN DD *"
call out '-- OPTIONS PREVIEW'
return
endProcedure genUtil
genDSN: procedure expose m.
parse arg m
m.m.stepNo = m.m.stepNo + 1
call out "//STEP"m.m.stepNo ,
" EXEC PGM=IKJEFT01"
call out "//SYSTSPRT DD SYSOUT=*"
call out "//SYSPRINT DD SYSOUT=*"
call out "//SYSTSIN DD *"
call out "DSN SYS("m.m.dbSy")"
return
endProcedure genDsn
/* rexx ****************************************************************
wsh: walter's rexx shell
interfaces:
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
--- history ------------------------------------------------------------------
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
********/ /*** end of help ********************************************
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class.classO
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
call pipeIni /* without tstClass2 gives different result */
m.wsh.version = 2.2
parse arg spec
if spec = '?' then
return help('wsh version' m.wsh.version)
isEdit = 0
if spec = '' & m.err.ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
if spec = '?' then
return help('version' m.wsh.version)
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
call scanIni
f1 = spec
rest = ''
if pos(verify(f1, m.scan.alfNum), '1 2') > 0 then
parse var spec f1 2 rest
u1 = translate(f1)
if u1 = 'T' then
return wshTst(rest)
else if u1 = 'I' then
return wshInter(rest)
else if u1 = 'S' then
spec = '$#@ call sqlStmtsOpt $.$sqlIn,' quote(rest) '$#sqlIn#='
call wshIni
inp = ''
out = ''
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = s2o('-wsh')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = s2o('-out')
end
end
else if m.err.os == 'LINUX' then do
inp = s2o('&in')
out = s2o('&out')
end
else
call err 'implement wsh for os' m.err.os
m.wshInfo = 'compile'
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit 0
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
call scanWinIni
return
endProcedure wshIni
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect DBAF
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
return 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call errMsg ggTxt
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.scan.alfLC)
c1 = substr(m.scan.alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then
call tstZos
call tstTut0
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call tstTime
call sqlIni
call tstSql
call tstSqlC
call tstSqlQ
call tstSqlUpdComLoop
call tstSqlB
call tstSqlStmt
call tstSqlStmts
call tstSqlO1
call tstSqlO2
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*
$=/tstSorQ/
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSorQ/ */
/*
$=/tstSorQAscii/
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSorQAscii/ */
if m.err.os == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.55.789008
Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs
timeZone 3600.00000 leapSecs 25.0000000
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.55.789008
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D7A670B7C
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741)( C5E963363741
$/tstTime/
*/
call jIni
call tst t, 'tstTime'
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out ,
'Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs'
call out 'timeZone' m.timeZone * m.timeStckUnit ,
'leapSecs' m.timeLeap * m.timeStckUnit
call timeReadCvt 1
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
call out 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
call tstEnd t
return
endProcedure tstTime
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlConnect
call jIni
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: stmt = prepare s7 from :src
. e 2: with from :src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.sqlInd, :M.STST.B :M.STST.B.sqlInd, :M.+
STST.C :M.STST.C.sqlInd
1 all from dummy1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
sql2St 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
$/tstSql/ */
call tst t, "tstSql"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sql2St(,
"select 'a' a, 2 b, case when 1=0 then 1 else null end c",
"from sysibm.sysDummy1",
, stst) 'all from dummy1'
call out 'a='m.stst.1.a 'b='m.stst.1.b 'c='m.stst.1.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = 'select name' ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name) name" ,
substr(src,12)
call out 'sql2St' sql2St(src, st)
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call tstEnd t
return
endProcedure tstSql
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlPreOpen cx
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call tstEnd t
return
endProcedure tstSqlB
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: stmt = prepare s7 from :src
. e 2: with from :src = select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call sqlStmt 'set current schema = A540769';
call tst t, "tstSqlO"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call tstEnd t
return
endProcedure tstSqlO
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-XTENTS-LOADRLAST+
TIME--------------REORGLASTTIME--------------EORGINSERTS-EORGDELETE+
S-EORGUPDATES-GUNCLUSTINS-RGDISORGLOB-GMASSDELETE-GNEARINDREF-RGFAR+
INDREF-STATSLASTTIME--------------TATSINSERTS-TATSDELETES-TATSUPDAT+
ES-SMASSDELETE-COPYLASTTIME---------------PDATEDPAGES-COPYCHANGES-C+
OPYUP-COPYUPDATETIME-------------I---DBID---PSID-TITION-STANCE-SPAC+
E---TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-REORG+
SC-REORGHA-HASHLASTUS-DRI-L-STATS01----
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-XTENTS-LOADRLASTTIME--------------REORGLASTTIME----+
----------EORGINSERTS-EORGDELETES-EORGUPDATES-GUNCLUSTINS-RGDISORG+
LOB-GMASSDELETE-GNEARINDREF-RGFARINDREF-STATSLASTTIME--------------+
TATSINSERTS-TATSDELETES-TATSUPDATES-SMASSDELETE-COPYLASTTIME-------+
--------PDATEDPAGES-COPYCHANGES-COPYUP-COPYUPDATETIME-------------+
I---DBID---PSID-SPACE---TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REO+
RGHA-HASHLASTUS-DRI-L-STATS01----
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-XTENTS-LOADRLASTTIME--------------REORGLASTTIME----+
----------EORGINSERTS-EORGDELETES-EORGUPDATES-GUNCLUSTINS-RGDISORG+
LOB-GMASSDELETE-GNEARINDREF-RGFARINDREF-STATSLASTTIME--------------+
TATSINSERTS-TATSDELETES-TATSUPDATES-SMASSDELETE-COPYLASTTIME-------+
--------PDATEDPAGES-COPYCHANGES-COPYUP-COPYUPDATETIME-------------+
I---DBID---PSID-SPACE---TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REO+
RGHA-HASHLASTUS-DRI-L-STATS01----
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REORGSC+
ANACCESS DRIVETYPE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASIZE +
. REORGHASHACCESS LPFACILITY
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTERSEN+
S HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlPreOpen 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabReset abc, 17, 1, , 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlopen 17
call sqlFTabReset abc, 17, 2 1, 1 3 'c', 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
call fTabAddTit abc, 2, 'others vorher'
call fTabAddTit abc, 3, 'others nachher'
call sqlFTabOthers abc
call sqlFTab abc
call sqlClose 17
call tstEnd t
return
endProcedure tstSqlFTab
tstSqlC: procedure expose m.
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: stmt = prepare s9 into :M.SQL.9.D from :src
. e 6: with into :M.SQL.9.D = M.SQL.9.D
. e 7: from :src = select * from sysibm?sysDummy1
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: stmt = prepare s9 into :M.SQL.9.D from :src
. e 2: with into :M.SQL.9.D = M.SQL.9.D
. e 3: from :src = select * from nonono.sysDummy1
sys ==> server CHSKA000DBAF .
fetched a1=abc, i2=12, c3=---
. I1 C2 .
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: stmt = select * from sysibm?sysDummy1
. e 6: subsys = DD0G, host = RZ8, interfaceType Csm
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: stmt = select * from nonono.sysDummy1
. e 2: subsys = DD0G, host = RZ8, interfaceType Csm
sys rz8/DD0G ==> server CHROI000DD0G .
fetched a1=abc, i2=12, c3=---
. I1 C2 .
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sqlBuf = jBuf("select 1 i1, 'eins' c2 from sysibm.sysDummy1",
, "union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1")
do tx=1 to 2
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
call sqlConnect
end
else do
call tst t, "tstSqlCCsm"
sys = 'rz8/DD0G'
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fmtFTab , sqlRdr(sqlBuf)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlQ: procedure expose m.
/*
$=/tstSqlQ/
### start tst tstSqlQ #############################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
. from :src = select * from final table (update session.dgtt s+
et c2 = 'u' || c2)
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlQ/ */
call tst t, "tstSqlQ"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call tstEnd t
return
endProcedure tstSqlQ
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: stmt = prepare s7 from :src
. e 2: with from :src = select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call sqlStmt 'set current schema = A540769';
call tst t, "tstSqlO"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
T
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call out sqlStmt("declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows")
call out sqlStmt("insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only")
call out sqlStmt("select count(*) cnt from session.dgtt")
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call out sqlStmt("select count(*) cnt from session.dgtt")
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlConnect
call tst t, "tstSqlO1"
sq = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen sq, m.j.cRead
do while assNN('ABC', jReadO(sq))
if m.sq.rowCount = 1 then do
cx = m.sq.cursor
call mAdd t.trans, className(m.sql.cx.type) '<tstSqlO1Type>'
end
call outO abc
end
call jClose sq
call out '--- writeAll'
call pipeWriteAll sq
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlConnect
call tst t, "tstSqlO2"
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fmtFTab abc
call pipe '-'
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlOIni
call tst t, "tstSqlS1"
call sqlConnect dbaf
s1 = fileSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, fileSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: stmt = execute immediate :ggSrc
. e 3: with immediate :ggSrc = set current schema = 'sysibm'
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/ */
call sqlConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* SQL u f C v'))
call mAdd t.trans, cn '<sql?sc>'
call tstOut t, sqlStmt("set current schema = 'sysibm'")
call tstOut t, sqlStmt(" set current schema = sysibm ")
call tstOut t, sqlStmt(" select current schema c from sysDummy1",
, ,'o')
call tstOut t, sqlStmt(" (select current schema c from sysDummy1)",
, ,'o')
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: stmt = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
sqlCode 0: set current schema = s100447
#jIn eof 3#
$/tstSqlStmts/ */
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b, , '-sql72'
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call tstEnd t
return
endProcedure tstSqlStmts
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompStmtA
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
$/tstCompPrimary/ */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.-{"abc"}=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.-{""abc""}="$.-{"abc"}'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*
$=/tstCompExprCon/
$/tstCompExprCon/ */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompStmtA: procedure expose m.
call pipeIni
/*
$=/tstCompStmtAssAtt/
### start tst tstCompStmtAssAtt ###################################
compile @, 19 lines: call tstCompStmtAA "begin", "tstAssAtt"
run without input
begin tstAssAtt F1=F1val1 F2= F3= FR=
gugus1
ass1 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=
ass2 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=<oAAR2>
ass2 tstAssAr2 F1=FRF1ass2 F2= F3= FR=
gugus3
ass3 tstAssAtt F1=F1val1 F2=F2ass3 F3=F3ass1 FR=<oAAR2>
ass3 tstAssAr2 F1=FRF1ass2 F2=FrF2ass3 F3= FR=<oAAR3>
ass3 tstAssAr3 F1=r2F1as3 F2=r2F2as3 F3= FR=
*** err: no field falsch in class tstAssAtt in EnvPut(falsch, +
falsch, 1)
$/tstCompStmtAssAtt/
*/
call classNew 'n? tstAssAtt u f F1 v, f F2 v,' ,
'f F3 v, f FR r tstAssAtt'
call envPutO 'tstAssAtt', oNew('tstAssAtt')
call envPut 'tstAssAtt.F1', 'F1val1'
call tstComp1 '@ tstCompStmtAssAtt',
, 'call tstCompStmtAA "begin", "tstAssAtt"',
, '$=tstAssAtt=:¢F2=F2ass1 $$gugus1',
, 'F3=F3ass1',
, '!',
, 'call tstCompStmtAA "ass1", "tstAssAtt"',
, '$=tstAssAtt.FR.F1 = FRF1ass2',
, '$=tstAssAr2 =. ${tstAssAtt.FR}',
, 'call mAdd T.trans, $.$tstAssAr2 "<oAAR2>"',
, 'call tstCompStmtAA "ass2", "tstAssAtt"',
';call tstCompStmtAA "ass2", "tstAssAr2"',
, '$=tstAssAtt=:¢F2=F2ass3 $$gugus3',
, ':/FR/ F2= FrF2ass3',
, 'FR=:¢F1=r2F1as3',
, 'F2=r2F2as3',
, ' * blabla $$ sdf',
, '!',
, '/FR/ !',
, '$=tstAssAr3 =. ${tstAssAtt.FR.FR}',
, 'call mAdd T.trans, $.$tstAssAr3 "<oAAR3>";',
'call tstCompStmtAA "ass3", "tstAssAtt";',
'call tstCompStmtAA "ass3", "tstAssAr2";',
'call tstCompStmtAA "ass3", "tstAssAr3"',
, '$=tstAssAtt=:¢falsch=falsch$!'
/*
$=/tstCompStmtAsSuTy/
### start tst tstCompStmtAsSuTy ###################################
compile @, 4 lines: call tstCompStmtA2 "begin", "tstAsSuTy"
run without input
begin tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GTF1ini1 F2= F3= FR=
as2 tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GtF1ass2 F2=F2ass2 F3= FR=
$/tstCompStmtAsSuTy/
*/
call classNew 'n? tstAsSuTy u f G1 v, f GT tstAssAtt'
call envPutO 'tstAsSuTy', oNew('tstAsSuTy')
call envPut 'tstAsSuTy.G1', 'G1ini1'
call envPut 'tstAsSuTy.GT.F1', 'GTF1ini1'
call tstComp1 '@ tstCompStmtAsSuTy',
, 'call tstCompStmtA2 "begin", "tstAsSuTy"',
, '$=tstAsSuTy.GT =:¢F1= GtF1ass2',
, 'F2= F2ass2 $!',
, 'call tstCompStmtA2 "as2", "tstAsSuTy"'
/*
$=/tstCompStmtAssSt/
### start tst tstCompStmtAssSt ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSt H1=H1ass2 HS.0=1 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSt/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', oNew('tstAssSt')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSt')'.HS.1'
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSt', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass2',
, 'HS =<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"',
, ''
/*
$=/tstCompStmtAssSR/
### start tst tstCompStmtAssSR ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASR>.HS class <clSR??> in EnvPut(ts+
tAssSR.HS.1.F1, HS.1.ini0, )
begin tstAssSR H1=H1ini1 HS.0=1 .
_..1 tstAssSR. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSR H1=H1ass2 HS.0=1 .
_..1 tstAssSR. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSR H1=H1ass3 HS.0=3 .
_..1 tstAssSR. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSR. F1= F2= F3= FR=
_..3 tstAssSR. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSR/
*/
cl = classNew('n? tstAssSR u f H1 v, f HS s r tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSR', oNew('tstAssSR')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSR')'.HS.1'
call envPut 'tstAssSR.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSR', '',
, "call mAdd t.trans, $.$tstAssSR '<oASR>'",
", m.tstCl '<clSR??>'",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSR.HS.0', 1",
";call envPutO 'tstAssSR.HS.1', ''",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass2',
, 'HS =<<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, ';call tstCompStmtSt "ass2", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSR"',
, ''
/*
$=/tstCompStmtassTb/
### start tst tstCompStmtassTb ####################################
compile @, 19 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
tstR: @tstWriteoV4 isA :<assCla H1>
tstR: .H1 = H1ass2
ass2 tstAssSt H1=H1ini1 HS.0=2 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
_..2 tstAssSt. F1= F2=h3+f2as2 F3=h3+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=f3as3 FR=
$/tstCompStmtassTb/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', oNew('tstAssSt')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSt')'.HS.1'
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtassTb', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢ $@|¢ H1 ',
, ' H1ass2 ',
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<assCla H1>'} $!",
, 'HS =<|¢ $*(...',
, '..$*) F2 F3 ',
, ' hs+f2as2 hs+f3as2 ' ,
, ' * kommentaerliiii ' ,
, ' ' ,
, ' h3+f2as2 h3+f3as22222$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
'$=tstAssSt =:¢H1= H1ass3',
, 'HS =<|¢F2 F3',
, ' f2as3' ,
, ' ',
, ' $""',
, ' f3as3 $! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"'
/*
$=/tstCompStmtassInp/
### start tst tstCompStmtassInp ###################################
compile @, 11 lines: .
run without input
tstR: @tstWriteoV2 isA :<cla123>
tstR: .eins = l1v1
tstR: .zwei = l1v2
tstR: .drei = l1v3
tstR: @tstWriteoV3 isA :<cla123>
tstR: .eins = l2v1
tstR: .zwei = l2v2
tstR: .drei = l21v3
*** err: undefined variable oo in envGetO(oo)
oo before 0
oo nachher <oo>
tstR: @tstWriteoV5 isA :<cla123>
tstR: .eins = o1v1
tstR: .zwei = o1v2
tstR: .drei = o1v3
$/tstCompStmtassInp/
*/
call envRemove 'oo'
call tstComp1 '@ tstCompStmtassInp', '',
, "$@|¢eins zwei drei ",
, " l1v1 l1v2 l1v3",
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<cla123>'}" ,
, " l2v1 l2v2 l21v3",
, "!",
, "$$ oo before $.$oo",
, "$; $>.$oo $@|¢eins zwei drei",
, " o1v1 o1v2 o1v3 $!",
, "$; call mAdd 'T.TRANS', $.$oo '<oo>'",
, "$; $$ oo nachher $.$oo $@$oo"
return
endProcedure tstCompStmtA
tstCompStmtAA: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'F1='left(envGet(ggN'.F1'), 8),
'F2='left(envGet(ggN'.F2'), 8),
'F3='left(envGet(ggN'.F3'), 8),
'FR='envGetO(ggN'.FR')
return
endSubroutine
tstCompStmtA2: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'G1='left(envGet(ggN'.G1'), 8)
call tstCompStmtAA '_..GT', ggN'.GT'
return
endSubroutine
tstCompStmtSt: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'H1='left(envGet(ggN'.H1'), 8),
'HS.0='left(envGet(ggN'.HS.0'), 8)
do sx=1 to envGet(ggN'.HS.0')
call tstCompStmtAA '_..'sx, ggN'.HS.'sx
end
return
endSubroutine tstCompStmtSt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 17 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@|
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
*** err: scanErr comp2code bad fr | to | for @|| .
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@|'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<={ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith with $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun()
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call envPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun()', '$@oRun-{}' ,
, ' $@oRun-{$"-{1 arg only}" ''oder?''}' ,
, ' $@oRun.{$".{1 obj only}" ''oder?''} $=v2=zwei' ,
, ' $@oRun-{$"{2 args}", "und" $v2"?"}' ,
, ' $@oRun-{$"{3 args}", $v2, "und drei?"}'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+ abc
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<$dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $>.$eins $@for vv $$ <$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>.$eins $@for vv $$ <$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
$/tstCompDirSrc/ */
/*
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
$/tstCompDir/ */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@pi2()
$#pi2#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#=, 6 lines: +
zeile 1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#="
return
endProcedure tstCompDir
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fmtFTab abc
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DBAF
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* -{sysvar(sysnode) date() time()} ts=$ts 10*len=$-{length($ts) * 10}
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out 20130224 11:48:24
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DBAF
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out 20101229 13
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DBAF
$@|¢
db ts
DGDB9998 A976
DA540769 A977
!
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DBAF
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out 20101229
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#@
$=subsys = dbaf
$=lst=<:¢
db = DGDB9998
ts =<|¢
ts
A976
A977
!;
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out 201012
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dbtf
$@|¢ ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fmtFtab
$|
$=jx=0
$@forWith t $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect dbaf
$#out 20101231 11:56:23
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 46 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlOIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
call tstComp2 'tstTut04'
call tstComp2 'tstTut05'
call tstComp2 'tstTut07'
call tstTotal
return
endProcedure tstTut0
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstO
call tstM
call classIni
call tstMCat
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstOEins
call tstOGet
call jIni
call tstJSay
call tstJ
call tstJ2
call tstJCatSql
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstEnvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstF
call tstFTab
call tstFmt
call tstFmtUnits
call tstTotal
call scanIni
call tstSb
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMCat: procedure expose m.
/*
$=/tstMCat/
### start tst tstMCat #############################################
mCat(0, ) =;
mCat(0, %qn1%s) =;
mCat(0, %qn112222%s%qe%s11) =;
mCat(0, 1%s%qn231%s%qe%s2) =;
mCat(0, 1%s2@%s%qn33341%s2@%s%=;
mCat(0, 1%s2@%s3@%s%qn451%s2@%=;
mCat(1, ) =eins;
mCat(1, %qn1%s) =eins;
mCat(1, %qn112222%s%qe%s11) =eins11;
mCat(1, 1%s%qn231%s%qe%s2) =1eins2;
mCat(1, 1%s2@%s%qn33341%s2@%s%=1eins2eins333;
mCat(1, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins4;
mCat(2, ) =einszwei;
mCat(2, %qn1%s) =eins1zwei;
mCat(2, %qn112222%s%qe%s11) =eins112222zwei11;
mCat(2, 1%s%qn231%s%qe%s2) =1eins231zwei2;
mCat(2, 1%s2@%s%qn33341%s2@%s%=1eins2eins33341zwei2zwei333;
mCat(2, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins451zwei2zwei3zwei4;
mCat(3, ) =einszweidrei;
mCat(3, %qn1%s) =eins1zwei1drei;
mCat(3, %qn112222%s%qe%s11) =eins112222zwei112222drei11;
mCat(3, 1%s%qn231%s%qe%s2) =1eins231zwei231drei2;
mCat(3, 1%s2@%s%qn33341%s2@%s%=1eins2eins33341zwei2zwei33341drei2dr+
ei333;
mCat(3, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstMCat/ */
call mIni
call tst t, "tstMCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstMCat1 qx
call tstMCat1 qx, '%qn1%s'
call tstMCat1 qx, '%qn112222%s%qe%s11'
call tstMCat1 qx, '1%s%qn231%s%qe%s2'
call tstMCat1 qx, '1%s2@%s%qn33341%s2@%s%qe333'
call tstMCat1 qx, '1%s2@%s3@%s%qn451%s2@%s3@%s%qe4'
end
call tstEnd t
return
endProcedure tstMCat
tstMCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("mCat("m.qq.0"," fmt")", 30)"="mCat(qq, fmt)";"
return
endProcedure tstMCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2o2/
### start tst tstClass2 ###########################################
@CLASS.5 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice v union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .2 refTo @CLASS.6 :class = c
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.7 :class = u
. choice u stem 0
. .3 refTo @CLASS.8 :class = c
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.9 :class = c
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .5 refTo @CLASS.10 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.12 :class = r
. choice r .CLASS refTo @CLASS.5 done :class @CLASS.5
. .6 refTo @CLASS.13 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .7 refTo @CLASS.14 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.16 :class = c
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.15 done :class @CLASS.15
. .9 refTo @CLASS.19 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.20 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.11 done :class @CLASS.11
. .10 refTo @CLASS.21 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.20 done :class @CLASS.20
. .11 refTo @CLASS.22 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.23 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.24 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
$/tstClass2o2/
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.108 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2/ */
call classIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: bad type v: classBasicNew(v, tstClassTf12, )
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.3
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.3
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: bad type v:' ,
'classBasicNew(v, tstClassTf12, )'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, class4Name('tstClassTf12')
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class.classV m.class.classW m.class.classO) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'m.t.class)
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
oIsCla(TstOCla1) 0
TstOCla1 -
oIsCla(TstOCla1) 1
TstOCla1 -
oIsCla(TstOCla1) 1
TstOCla1 contents of met1
TstOCla1.met2 -
TstOCla2.met1 contents of met1
TstOCla2.met2 contents of met2
TstOCla1.TstOMet3 -
TstOCla1.TstOMet3 generated met TstOCla1:TstOMet3 code...;
TstOCla2.TstOMet3 generated met TstOCla2:TstOMet3 code...;
tstOObj1.met1 -
tstOObj1.met1 contents of met1
$/tstO/
*/
call mIni
call tst t, 'tstO'
call oIni
c1 = 'TstOCla1'
c2 = 'TstOCla2'
m1 = 'met1'
m2 = 'met2'
m3 = 'TstOMet3'
lg = m.o.lazyGen
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, 'met1', '-')
call oAddCla c1
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, 'met1', '-')
call oAddMet c1, m1, 'contents of met1'
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, m1, '-')
call oAddCla c2, c1
call oAddMet c2, 'met2', 'contents of met2'
call tstOut t, c1'.met2' oClaMet(c1, 'met2', '-')
call tstOut t, c2'.'m1 oClaMet(c2, m1, '-')
call tstOut t, c2'.met2' oClaMet(c2, 'met2', '-')
call tstOut t, c1'.'m3 oClaMet(c1, m3, '-')
call oAddMet lg, m3,
, "return 'generated met' cl':'me 'code...;'"
call tstOut t, c1'.'m3 oClaMet(c1, m3, '-')
call tstOut t, c2'.'m3 oClaMet(c2, m3, '-')
o1 = 'tstOObj1'
o2 = 'tstOObj2'
call tstOut t, o1'.met1' objMet(o1, 'met1', '-')
call oMutate o1, c1
call tstOut t, o1'.met1' objMet(o1, 'met1', '-')
call tstEnd t
drop m.o.cParent.c1 m.o.cMet.c1.m1 m.o.cMet.c1.m2 m.o.cMet.c1.m3
drop m.o.cParent.c2 m.o.cMet.c2.m1 m.o.cMet.c2.m2 m.o.cMet.c2.m3
drop m.o.o2c.o1 m.o.cMet.lg.m3
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :CLASS.3
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret oClaMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'FLDS of' e mCat(oFlds(e), '%qn, %s')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret oClaMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), '%qn, %s')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
/* call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), '%qn, %s')
*/
call oMutate c1, class4Name('TstOEins')
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, class4Name('TstOElf')
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOGet: procedure expose m.
/*
$=/tstOGet/
### start tst tstOGet #############################################
class.NAME= class
class.NAME= class : w
class| = u
*** err: bad stem index 91>7 @ CLASS.4 class class in oGet(CLASS.4,+
. 91)
class.91 = 0
class.1 = CLASS.1 |= u
class.2 = CLASS.5 |= c
$/tstOGet/ */
call oIni
call tst t, 'tstOGet'
cc = m.class.class
call tstOut t, 'class.NAME=' oGet(cc, 'NAME')
o = oGetO(cc, 'NAME')
call tstOut t, 'class.NAME=' o2String(o) ':' className(objClass(o))
call tstOut t, 'class| =' oGet(cc, '|')
call tstOut t, 'class.91 =' className(oGet(cc, 91))
call tstOut t, 'class.1 =' oGetO(cc, '1') '|=' oGet(cc, '1||')
call tstOut t, 'class.2 =' className(oGetO(cc, '2')) ,
'|=' oGet(cc, '2||')
call tstEnd t
/*
$=/tstOGet2/
### start tst tstOGet2 ############################################
tstOGet1 get1 w
tstOGet1.f1 get1.f1 v
tstOGet1.f2 get1.f2 w
tstOGet1.F3| get1.f3 v
tstOGet1.f3.fEins get1.f3.fEins v
tstOGet1.f3.fZwei get1.f3.fZwei w
tstOGet1.f3%fDrei !get1.f3.fDrei w
tstOGet1.f3.fDrei get1.f3.fDrei w
tstOGet1.f3%1 get1.f3.fDrei.1 w
tstOGet1.f3.2 TSTOGET1
tstOGet1.f3.2|f1 get1.f1 v
tstOGet1.f3.2|f3.2|f2 get1.f2 w
*** err: bad stem index 4>3 @ TSTOGET1.F3 class TstOGet0 in oGet(TS+
TOGET1, F3.4)
tstOGet1.f3.4 0
tstOGet1.f3.3 get1.f3.fDrei.3 w
*** err: bad stem index 3>3A @ TSTOGET1.F3 class TstOGet0 in oGet(T+
STOGET1, F3.3)
tstOGet1.f3.2 0
$/tstOGet2/
*/
c0 = classNew('n? TstOGet0 u f FEINS v,f FZWEI w,f FDREI r,v,' ,
's r TstOGet0')
cl = classNew('n? TstOGet u r, f F1 v, f F2 r, f F3 TstOGet0')
call oMutate tstOGet1, cl
m.tstOGet1 = s2o('get1 w')
m.tstOGet1.f1 = 'get1.f1 v'
m.tstOGet1.f2 = s2o('get1.f2 w')
m.tstOGet1.f3 = 'get1.f3 v'
m.tstOGet1.f3.fEins = 'get1.f3.fEins v'
m.tstOGet1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstOGet1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstOGet1.f3.0 = 3
m.tstOGet1.f3.1 = s2o('get1.f3.fDrei.1 w')
m.tstOGet1.f3.2 = tstOGet1
m.tstOGet1.f3.3 = s2o('get1.f3.fDrei.3 w')
call tst t, 'tstOGet2'
call tstOut t, 'tstOGet1 ' oGet(tstOGet1, )
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call tstOut t, 'tstOGet1.f2 ' oGet(tstOGet1, f2)
call tstOut t, 'tstOGet1.F3| ' oGet(tstOGet1, 'F3|')
call tstOut t, 'tstOGet1.f3.fEins ' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3.fZwei ' oGet(tstOGet1, f3.fZwei)
call tstOut t, 'tstOGet1.f3%fDrei ' oGetO(tstOGet1, 'F3%FDREI')
call tstOut t, 'tstOGet1.f3.fDrei ' oGet(tstOGet1, f3.fDrei)
call tstOut t, 'tstOGet1.f3%1 ' oGet(tstOGet1, 'F3%1')
call tstOut t, 'tstOGet1.f3.2 ' oGetO(tstOGet1, 'F3.2')
call tstOut t, 'tstOGet1.f3.2|f1 ' oGet(tstOGet1, 'F3.2|F1')
call tstOut t, 'tstOGet1.f3.2|f3.2|f2' ,
oGet(tstOGet1, 'F3.2|F3.2|F2')
call tstOut t, 'tstOGet1.f3.4 ' oGet(tstOGet1, 'F3.4')
call tstOut t, 'tstOGet1.f3.3 ' oGet(tstOGet1, 'F3.3')
m.tstOGet1.f3.0 = 3a
call tstOut t, 'tstOGet1.f3.2 ' oGet(tstOGet1, 'F3.3')
call tstEnd t
/*
$=/tstOPut3/
### start tst tstOPut3 ############################################
tstOGet1.f1 get1.f1 v
tstOGet1.f1 aPut1 f1.put1
tstOGet1.f2 aPut2 f2.put2
tstOGet1.f3.fEins p3 f3.fEins,p3
tstOGet1.f3%0 3A
tstOGet1.f3%0 =4 4
tstOGet1.f3.4.feins val f3.4|feins
$/tstOPut3/
*/
call tst t, 'tstOPut3'
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call oPut tstOget1, f1, 'f1.put1'
call tstOut t, 'tstOGet1.f1 aPut1' oGet(tstOGet1, f1)
call oPut tstOget1, f2, 'f2.put2'
call tstOut t, 'tstOGet1.f2 aPut2' oGet(tstOGet1, f2)
call oPut tstOget1, f3.fEins, 'f3.fEins,p3'
call tstOut t, 'tstOGet1.f3.fEins p3' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3%0 ' oGet(tstOGet1, 'F3%0')
call oPut tstOget1, f3.0, 4
call tstOut t, 'tstOGet1.f3%0 =4' oGet(tstOGet1, 'F3%0')
call oPutO tstOget1, 'F3.4', ''
call oPut tstOget1, 'F3.4|FEINS', 'val f3.4|feins'
call tstOut t, 'tstOGet1.f3.4.feins' ,
oGet(tstOGet1, 'F3.4|FEINS')
call tstEnd t
return
endProcedure tstOGet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay.jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Af', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 's',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
$/tstEnvVars/ */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
call pipe '+F' , envGetO('theBuf', '-b')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, envGetO('theBuf')
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvVars
tstEnvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1| get1 w
tstK1%f1 get1.f1 v
tstK1.f2 get1.f2 w
tstK1%F3 get1.f3 v
ttstK1.F3.FEINS get1.f3.fEins v
tstK1%F3%FZWEI get1.f3.fZwei w
tstK1.F3.FDREI !get1.f3.fDrei w
tstK1%F3%FDREI| get1.f3.fDrei w
tstK1.F3.1 get1.f3.1 w
tstK1%F3%2 TSTEW1
tstK1.F3.2|F1 get1.f1 v
tstK1%F3%2|F3.2|F2 get1.f2 w
*** err: undefined variable F1 in envGet(F1)
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3%FDREI !get1.f3.fDrei w
F3%FDREI| get1.f3.fDrei w
F3%1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined variable F1 in envGet(F1)
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call envPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1| ' envGet('tstK1|')
call tstOut t, 'tstK1%f1 ' envGet('tstK1%F1')
call tstOut t, 'tstK1.f2 ' envGet('tstK1.F2')
call tstOut t, 'tstK1%F3 ' envGet('tstK1%F3|')
call tstOut t, 'ttstK1.F3.FEINS ' envGet('tstK1.F3.FEINS')
call tstOut t, 'tstK1%F3%FZWEI ' envGet('tstK1%F3%FZWEI')
call tstOut t, 'tstK1.F3.FDREI ' envGetO('tstK1.F3.FDREI')
call tstOut t, 'tstK1%F3%FDREI| ' envGet('tstK1%F3%FDREI')
call tstOut t, 'tstK1.F3.1 ' envGet('tstK1.F3.1')
call tstOut t, 'tstK1%F3%2 ' envGetO('tstK1%F3%2')
call tstOut t, 'tstK1.F3.2|F1 ' envGet('tstK1.F3.2|F1')
call tstOut t, 'tstK1%F3%2|F3.2|F2' ,
envGet('tstK1%F3%2|F3%2|F2')
call tstOut t, 'F1 ' envGet('F1')
call envPushWith tstEW1
call tstOut t, 'F1 ' envGet('F1')
call tstOut t, 'f2 ' envGet('F2')
call tstOut t, 'F3 ' envGet('F3|')
call tstOut t, 'F3.FEINS ' envGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' envGet('F3.FZWEI')
call tstOut t, 'F3%FDREI ' envGetO('F3%FDREI')
call tstOut t, 'F3%FDREI| ' envGet('F3%FDREI|')
call tstOut t, 'F3%1 ' envGet('F3%1')
call tstOut t, 'pu1 F1 ' envGet('F1')
call envPushWith tstEW2
call tstOut t, 'pu2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-1 F1 ' envGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3.F1 = v(c3.f1)
*** err: no reference @ <c3>.F1 class CLASS.1 in envGet(c3.F1.FEINS+
)
. s c3.F1.FEINS = 0
. s c3.F3.FEINS = .
. s c3.F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS @ <c3> class TstEW in envGet(c3.FEINS)
. s c3.FEINS = 0
*** err: null @ <c3> class TstEW in envGet(c3|FEINS)
. s c3|FEINS = 0
aft Put s c3|FEINS = val(c3|FEINS)
Push c3 s F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS aftPuP= pushPut(F3 @ <c3>.F3 class TstEW0 i+
n envGet(F3.FEINS aftPuP= pushPut(F3.FEINS))
. s F3.FEINS aftPuP= 0
push c4 s F1 = v(c4.f1)
put f2 s F2 = put(f2)
*** err: no field F222 in class TstEW in EnvPut(F222, f222 stopped,+
. 1)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3.f1)
*** err: undefined variable F1 in envGet(F1)
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3.f1)'
call envPutO 'c3', c3
call tstEnvSG , 'c3.F1'
call tstEnvSG , 'c3.F1.FEINS'
call tstEnvSG , 'c3.F3.FEINS'
call envPut 'c3.F3.FEINS', 'val(c3.F3.FEINS)'
call tstEnvSG , 'c3.F3.FEINS'
call tstEnvSG , 'c3.FEINS'
call tstEnvSG , 'c3|FEINS'
call envPut 'c3|FEINS', 'val(c3|FEINS)'
call tstEnvSG 'aft Put', 'c3|FEINS'
call envPushWith c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call envPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG , 'F3.FEINS aftPuP=' envGet('F3.FEINS')
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4.f1)'
call envPut f222, 'f222 no stop'
call envPushWith c4
call tstEnvSG 'push c4', f1
call envPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call envPut f222, 'f222 stopped', 1
call envPut f3.fEins, 'put(f3.fEins)'
call tstEnvSG 'put .. ', f3.fEins
call envPopWith
call tstEnvSG 'popW c4', f1
call envPopWith
call envPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
/*
$=/tstEW4/
### start tst tstEW4 ##############################################
tstO4 S.0 0 R.0 0 class TstEW4
*** err: no field FZWEI in class in EnvPut(FZWEI, v 1.fZwei, 1)
1 fEins s FEINS = v 1.fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1.fEins .# 1 vor
v 1.fEins .# 2 nach withNext e
*** err: undefined variable FEINS in envGet(FEINS)
? fEins s FEINS = 0
1 fEins s FEINS = v 1|fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1|fEins .# 2
$/tstEW4/
*/
c4 = classNew('n? TstEW4 u f S s TstEW0, f R s r TstEW0')
o4 = oClear(oMutate('tstO4', c4))
call tst t, 'tstEW4'
call tstout t, o4 'S.0' m.o4.s.0 'R.0' m.o4.r.0 ,
'class' className(objClass(o4))
call envPushWith o4'.S', m.c4.f2c.s, 'asM'
call envPut fZwei, 'v 1.fZwei', 1
call envWithNext 'b'
call envPut feins, 'v 1.fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
m.o4.s.2.feins = 'vorher'
m.o4.s.2.fZwei = s2o('vorher')
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'vor'
call envWithNext 'e'
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'nach withNext e'
call envPopWith
call tstEnvSG '? fEins ', fEins
call envPushWith o4'.R', m.c4.f2c.r, 'asM'
call envWithNext 'b'
call envPut fEins, 'v 1|fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call envWithNext 'e'
call envPopWith
o41r = m.o4.r.1
call tstOut t, m.o41r.fEins '.#' m.o4.r.0
call tstEnd t
return
endProcedure tstEnvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' envGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+f', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%s345%S67\%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\s23%s345%S67\%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%s3@2%S4@%s5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%s2@f2%s3@F3%s4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5i @%8i @%+8i @%-8i -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan Text? gerText? gerText? undEinLa
tstF2 _ %-9C @%5.2i @%12.2i @%+12.2i @%-12.2i -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan Text? nLangerText? nLangerText? undEinLanger
tstF2 _ %-9C @%7e @%8E @%9.2e @%11.3E -----
_ 0 0.00e00 0.00E00 0.00e+00 0.000E+000
_ -1.2 -1.2e00 -1.20E00 -1.20e+00 -1.200E+000
_ 2.34 2.34e00 2.34E00 2.34e+00 2.340E+000
_ -34.8765 -3.5e01 -3.49E01 -3.49e+01 -3.488E+001
_ 567.91234 5.68e02 5.68E02 5.68e+02 5.679E+002
_ -8901 -8.9e03 -8.90E03 -8.90e+03 -8.901E+003
_ 23456 2.35e04 2.35E04 2.35e+04 2.346E+004
_ -789012 -7.9e05 -7.89E05 -7.89e+05 -7.890E+005
_ 34e6 3.40e07 3.40E07 3.40e+07 3.400E+007
_ -56e7 -5.6e08 -5.60E08 -5.60e+08 -5.600E+008
_ 89e8 8.90e09 8.90E09 8.90e+09 8.900E+009
_ txtli txtli txtli txtli txtli .
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.76e-07 8.760E-007
_ 5.43e-11 0.05e-9 0.05E-9 5.43e-11 5.430E-011
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.76e-07 -8.760E-007
_ -5.43e-11 -0.1e-9 -0.05E-9 -5.43e-11 -5.430E-011
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\S23%s345%S67\%8'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\s23%s345%S67\%8'
call tstF1 '1%S2%s3@2%S4@%s5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%s2@f2%s3@F3%s4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5i @%8i @%+8i @%-8i', nums
call tstF2 '_ %-9C @%5.2i @%12.2i @%+12.2i @%-12.2i', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @%8E @%9.2e @%11.3E', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call out "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call out 'tstF2' fmt '-----'
do vx=1 to words(vals)
call out f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fmtFTab abc, b
call fmtFAddFlds fmtFReset(abc), oFlds(m.st.1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteSt abc, b'.BUF'
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
call pipeIni
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-ex6-------
-11 -11 b3 -11+d4++++ -111.100 0.00e-9
-1 -10 b 4-10+d4+++ null1 null3 .
- -9 b3b-9 d4-9+d4+++ -11.000 -0.1e-9
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2 .
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1 .
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2 .
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3 .
11+ 11 b3 11+d4+++++ 0.111 0.00e-9
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 0.00e-9
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1 .
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2 .
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-ex6-------
testData end
$/tstFTab/ */
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3
call fTabAdd ft, '.' , '%-6C' , '.', 'testData begin',
, 'testData end'
call fTabAdd ft, 'a2i' , ' %6i'
call fTabAdd ft, 'b3b' , ' %-12C'
call fTabAdd ft, 'd4' , ' %10C'
call fTabAdd ft, 'fl5' , ' %8.3i'
call fTabAdd ft, 'ex6' , ' %7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstfmtUnits: procedure
/*
$=/tstFmtUnits/
### start tst tstFmtUnits #########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstFmtUnits/ */
call jIni
call tst t, "tstFmtUnits"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfmtUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 .
strEnd ? : 0 .
strEnd ? : 1 ab?cd??gh
strEnd ") ": 1 ab
strEnd ") ": 1 cd) gh
$/tstSb/ */
call tst t, 'tstSb'
call sbSrc s, 'abcdefghijklkl ?'
call out 'end :' sbEnd(s)
call out 'char 3 :' sbChar(s, 3) m.s.tok
call out 'lit d? :' sbLit(s, 'd?') m.s.tok
call out 'lit de :' sbLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:' sbLit(s, 'de ? fg fgh') m.s.tok
call out 'while HIJ :' sbWhile(s, 'HIJ') m.s.tok
call out 'end :' sbEnd(s)
call out 'while Jih :' sbWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' sbWhile(s, '? klj') m.s.tok
call out 'end :' sbEnd(s)
call out 'while ? klj:' sbWhile(s, '? klj') m.s.tok
call out 'char 3 :' sbChar(s, 3) m.s.tok
call out 'lit :' sbLit(s, '') m.s.tok
call sbSrc s, 'abcdefdef ?'
call out 'until cba :' sbUntil(s, 'cba') m.s.tok
call out 'until ?qd :' sbUntil(s, '?qd') m.s.tok
call out 'until ?qr :' sbUntil(s, '?qr') m.s.tok
call out 'until ?qr :' sbUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' sbStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' sbStrEnd(s, '?') m.s.tok
call sbSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' sbStrEnd(s, '?') m.s.tok
call sbSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' sbStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' sbStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b), '>')
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)), '>')
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(scanUtilReset(ScanRead(b)), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstjCatSql: procedure expose m.
/*
$=/tstJCatSql/
### start tst tstJCatSql ##########################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 .
$/tstJCatSql/ */
call tst t, 'tstJCatSql'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ')
call jCatSqlReset tstJCat, , jOpen(b, '<'), 30
do sx=1 until nx = ''
nx = jCatSqlNext(tstJCat, ';')
call tstOut t, 'cmd'sx nx
end
call jClose b
call tstEnd t
return
endProcedure tstJCatSql
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
call oMutate m, class4name('Tst')
call oMutate m'.IN', class4name('Tst')
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
m.m.in.jReading = 1
m.m.in.jWriting = 1
m.m.in.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(repAll(data || li, '$ä', '/*'), '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
cl = objClass(var, '')
if cl == '' then do
if var == '' then
call tstOut t, 'tstR: @ obj null'
else
call tstOut t, 'no class for' var 'in tstWriteO|'
end
else if abbrev(var, m.o.escW) then do
call tstOut t, o2String(var)
end
else if cl == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
if right(m, 3) == '.IN' then
m = left(m, length(m)-3)
else
call err 'tstReadO bad m' m
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
call errMsg ggTxt
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy time begin -----------------------------------------------------
11.05.23 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
----------------------------------------------------------------------*/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* copy time end -----------------------------------------------------*/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = 'FMTF.F'
return fmtFWriteSt(fmtFReset('FMTF.F'), j2Buf(rdr)'.BUF', wiTi)
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteSt: procedure expose m. ?????????
parse arg m, st, wiTi
if m.st.0 < 1 then
return 0
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return st.0
fmtFWriteSt
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
f1 = substr(format(nMa, 2, 2, 9, 0), 7)
if f1 \= '' then
eMa = max(eMa, f1)
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
call compIniKI '=', "skeleton", "expression or block"
call compIniKI '.', "object", "expression or block"
call compIniKI '-', "string", "expression or block"
call compIniKI '@', "shell", "pipe or $;"
call compIniKI ':', "assignAttributes", "assignment or statement"
call compIniKI '|', "assignTable", "header, sfmt or expr"
call compIniKI '#', "text", "literal data"
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@:|'
m.m.chKin2 = '.-=#;:|'
m.m.chKinC = '.-=@'
m.m.chOp = '.-<@|?'
m.m.chOpNoFi = '.-@|?'
return m
endProcedure compReset
compIniKI: procedure expose m.
parse arg ki, m.comp.kind.ki.name, m.comp.kind.ki.expec
return
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
if src \== '' then
m.nn.cmpRdr = o2File(src)
else
m.nn.cmpRdr = ''
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKind) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc m.m.scan, spec
m.m.compSpec = 1
res = compCUnit(m, kind, 1)
do while abbrev(m.m.dir, '$#')
call envPutO substr(m.m.dir, 3, length(m.m.dir)-4),
, compCUnit(m, right(m.m.dir, 1))
end
if \ m.m.compSpec then
call jClose m.m.scan
return res
endProcedure compile
/*--- cUnit = compilation Unit = separate compilations
no nesting| --------------------------------------------*/
compCUnit: procedure expose m.
parse arg m, ki, isFirst
s = m.m.scan
code = ''
do forever
m.m.dir = ''
src = compUnit(m, ki, '$#')
if \ compDirective(m) then
return scanErr(s, m.comp.kind.ki.expec "expected: compile",
m.comp.kind.ki.name "stopped before end of input")
if \ compIsEmpty(m, src) then do
/*wkTst??? allow assTb in separatly compiled units */
if isFirst == 1 & m.src.type == ':' ,
& pos(' ', src) < 1 & abbrev(src, 'COMP.AST.') then
call mAdd src, '', ''
code = code || ';'compAst2code(m, src, ';')
end
if m.m.dir == 'eof' then do
if \ m.m.compSpec | m.m.cmpRdr == '' then
return oRunner(code)
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead
m.m.compSpec = 0
end
else if length(m.m.dir) == 3 then
ki = substr(m.m.dir, 3, 1)
else
return oRunner(code)
end
endProcedure compCUnit
/*--- directives divide cUnits ---------------------------------------*/
compDirective: procedure expose m.
parse arg m
m.m.dir = ''
s = m.m.scan
lk = scanLook(s)
cx = pos('#', lk, 3)
if \ abbrev(lk, '$#') then do
if \ scanAtEnd(m.m.scan) then
return 0
m.m.dir = 'eof'
return 1
end
else if scanLit(s, '$#end' , '$#out') then do
m.m.dir = 'eof'
return 1
end
else if pos(substr(lk, 3, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if cx > 3 & pos(substr(lk, cx+1, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, cx+1)
end
else
call scanErr s, 'bad directive:' word(lk, 1)
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan, 'directive mismatch' m.m.dir
return 1
endProcedure compDirective
/**** parse the whole syntax *******************************************
currently, with the old code generation,
parsing and code generation is intermixec
migrating to AST should will separate these tasks
***********************************************************************/
compUnit: procedure expose m.
parse arg m, kind, stopper
s = m.m.scan
if pos(kind, m.m.chKind';') < 1 then
return scanErr(s, 'bad kind' kind 'in compUnit(...'stopper')')
if stopper == '}' then do
if kind \== '#' then do
one = compExpr(m, 'b', translate(kind, ';', '@'))
if compisEmpty(m, one) then
return compAST(m, 'block')
else
return compAST(m, 'block', one)
end
tx = '= '
cb = 1
do forever /* scan nested { ... } pairs */
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
return compAst(m, 'block', tx)
end
else if pos(kind, '.-=') > 0 then do
return compData(m, kind)
end
else if pos(kind, '@;') > 0 then do
call compSpNlComment m
return compShell(m)
end
else if kind == '|' | kind == ':' then do
if kind == '|' then
res = compAssTab(m)
else
res = compAssAtt(m)
if abbrev(res, '#') then
return compAst(m, ':', substr(res, 3))
else
return compAst(m, ';', substr(res, 3))
end
else if kind == '#' then do
res = compAST(m, 'block')
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata until' stopper
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then do
if stopper = '$#' then
leave
call scanErr s, 'eof in heredata until' stopper
end
end
return res
end
endProcedure compUnit
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compAST(m, 'block')
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
a = compAst(m, ';')
m.a.text = ''
do forever
one = compPipe(m)
if one \== '' then
m.a.text = m.a.text || one
if \ scanLit(m.m.scan, '$;') then
return a
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsbw') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock,
, if(type=='w', m.m.chNotWord,m.m.chDol))
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki, 1)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki, withChain
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if withChain then do
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
compObj: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '?')
one = compBlock(m, ki pk)
if one \== '' then
return compAstAddOp(m, one, ki)
pp = ''
if pk \== '' then do
ki = right(pk, 1)
pp = left(pk, length(pk)-1)
end
one = compPrimary(m, translate(ki, '.', '@'), 0)
if one \== '' then
return pp || one
if ki == '.' then do
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKinC) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return pp'. compile(comp(j2Buf()), "'m.s.tok'")'
end
end
call scanBack s, pk
return ''
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compCheckNE(m, compExprBlock(m, '='),
, 'block or expr expected for file')
if \ abbrev(res, '.') then do
end
else if substr(res, verify(res, '.', n), 3) == '0* ' then do
st = word(res, 2)
if m.st.0 = 1 & abbrev(m.st.1, '. envGetO(') then
/* if undefined variable use new jbuf */
if pos(')', m.st.1) == length(m.st.1) then
m.st.1 = left(m.st.1, length(m.st.1)-1) ,
|| ", '-b')"
end
return compASTAddOp(m, res, '<')
endProcedure compFile
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, opt
s = m.m.scan
op = ''
if opt == '<' then do
call scanVerify s, m.m.chOpNoFi
op = m.s.tok
if scanLit(s, '<') then
return op'<'
end
call scanVerify s, m.m.chOp
op = op || m.s.tok
k1 = scanLook(s, 1)
if k1 \== '' & pos(k1, m.m.chKind) > 0 then do
call scanLit s, k1
return op || k1
end
if opt == '?' | op == '' | pos(right(op, 1), m.m.chKind) > 0 then
return op
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '<')
if right(pk, 1) == '<' then
return compAstAddOp(m, compFile(m), pk)
res = compBlock(m, ki pk)
if res \== '' then
return res
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, pk)
call scanBack s, pk
return res
endProcedure compExprBlock
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
inp = ''
out = ''
stmts = ''
sBef = ''
do forever
if scanLit(s, '$<') then
inp = inp',' comp2Code(m, compFile(m))
else if scanLit(s, '$>>', '$>') then
if out <> '' then
call scanErr s, 'duplicate output'
else
out = substr('?FA', length(m.s.tok), 1) ,
comp2Code(m, compFile(m))
else if scanLit(s, '$|') then do
if stmts == '' then
call scanErr s, 'stmts expected before $|'
sBef = sBef"; call pipe 'N|'" || stmts
stmts = ''
end
else do
one = comp2code(m, ';'compStmts(m))
if one == '' then
leave
stmts = stmts';' one
end
call compSpNlComment m
end
if sBef == '' then do
if inp == '' & out == '' then
return stmts
if stmts == '' then do
call scanErr s,'no statemtents in pipe'
stmts = '; call pipeWriteAll'
end
end
else if stmts == '' then
call scanErr s, 'stmts expected after $|'
inO = left('f', inp \== '')
inp = substr(inp, 3)
parse var out ouO out
if sBef == '' then
return "; call pipe '+"ouO || strip(inO"',"out","inp, "T", ","),
|| stmts"; call pipe '-'"
else
return "; call pipe '+N" || strip(inO"',,"inp, "T", ",") ,
|| substr(sBef, 17),
|| "; call pipe '"left(ouO'P', 1)"|'" ,
strip(","out,"T", ",") || stmts"; call pipe '-'"
endProcedure compPipe
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
res = compAss(m)
if res == '' then
call scanErr s, 'assignment expected after $='
return res
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNE(m, compExprBlock(m, '@'),
, "block or expr expected after $@"))
fu = m.s.tok
if fu == 'for' | fu == 'with' | fu == 'forWith' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m, 'with'),
, "statement after $@for" v))
if fu == 'forWith' then
st = 'call envSetWith envGetO('v');' st
if abbrev(fu, 'for') then
st = 'do while envReadO('v');' st'; end'
if fu == 'forWith' then
st = 'call envPushWith "";' st '; call envPopWith'
else if fu == 'with' then
st = 'call envPushName' v';' st '; call envPopWith'
return ';' st
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
call compSpComment m
suf = compExpr(m, 's', ';')
if \ compIsEmpty(m, suf) then
suf = comp2Code(m, ':'suf)
else if var \== '' then
call scanErr s, "$@do control construct expected"
else
suf = ''
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInter('return' comp2Code(m, '-'nm)), st
return '; '
end
if scanLit(s, '(') then do
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '{', '.{', '-{', '={') then do
br = m.s.tok
a = compExpr(m, 'b', if(br == '{', '-', left(br, 1)))
if \ scanLit(s, '}') then
call scanErr s, 'closing } expected after $@'fu || br
res = '; call oRun envGetO("'fu'")'
if pos(left(a, 1), 'ec') < 1 then
res = res',' comp2code(m, a)
return res
end
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
end
if scanLit(s, '$$') then
return compCheckNN(m, compExprBlock(m, '='),
, 'block or expression expected after $$')
return ''
endProcedure compStmt
compAss: procedure expose m.
parse arg m, aExt
s = m.m.scan
sla = scanLook(s)
slx = verify(sla, m.m.chKind'/'m.m.chOp, 'n')
if slx > 0 then
sla = left(sla, slx-1)
sla = pos('/', sla) > 0
nm = ''
if \ sla then do
nm = compExpr(m, 'b', '=')
if compIsEmpty(m, nm) then
return ''
nm = comp2Code(m, '-'nm)
if \ scanLit(s, "=") then
return scanErr(s, '= expected after $=' nm)
end
m.m.bName = ''
vl = compCheckNE(m, compExprBlock(m, '='),
, 'block or expression after $=' nm '=')
if sla then
if m.m.bName == '' then
call scanErr s, 'missing blockName'
else
nm = "'"m.m.bName"'"
va = compAstAftOp(m, vl)
if va \== '' & m.va.type == ':' then do
pu = "call envPushName" nm
if abbrev(m.m.astOps, '<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else if abbrev(m.m.astOps, '<<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else
call mAdd va, pu ", 'as1'", "call envPopWith"
return va
end
if compAstKind(m, vl) == '-' then
return '; call envPut' nm',' comp2Code(m, vl)aExt
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)aExt
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, dKi ops
s = m.m.scan
if \ scanLit(s, '{', '¢', '/') then
return ''
start = m.s.tok
if (ops \== '' & pos(right(ops, 1), m.m.chKind) < 1) ,
| pos(dKi, m.m.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block (def' dKi')')
if ops == '' then do
ki = dKi
end
else do
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
end
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper) then do
if pos(ki, ':|') < 1 | \ abbrev(stopper, '$') then
call scanErr s, 'ending' stopper 'expected after' starter
else if \ scanLit(s, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'or' substr(stopper, 2),
'expected after' starter
end
if abbrev(starter, '/') then
m.m.bName = substr(starter, 2, length(starter)-2)
else
m.m.bName = ''
if m.res.text == '' then
m.res.text = ' '
return compAstAddOp(m, res, ops)
endProcedure compBlock
compAssAtt: procedure expose m. aClass
parse arg m
res = ''
aClass = ''
s = m.m.scan
last = ''
do forever
if compSpNlComment(m, '*') then do
end
else if pos(scanLook(s, 1), '/!}') > 0 then do
leave
end
else if scanLit(s, ';', '$;') then do
if last = ';' then
res = res'; call envWithNext'
last = ';'
end
else do
s1 = compAss(m, ", 1")
if s1 == '' then do
s1 = compStmt(m)
if s1 == '' then
leave
end
else do
if last == ';' then
res = res'; call envWithNext'
last = 'a'
end
res = res';' comp2code(m, ';'s1)
end
if res == '' then
res = ';'
end
if last == '' then
return res
else
return '# call envWithNext "b";' res ,
'; call envWithNext "e";'
endProcedure compAssAtt
compAssTab: procedure expose m. aClass
parse arg m
s = m.m.scan
call compSpNlComment m, '*'
hy = 0
tab = ''
do forever
bx = m.s.pos
if \ scanName(s) then
leave
hx = hy + 1
h.hx.beg = bx
if hx > 1 & bx <= h.hy.end then
call scanErr s, 'header overlap' m.s.tok 'pos' bx
h.hx = m.s.tok
tab = tab', f' m.s.tok 'v'
h.hx.end = m.s.pos
hy = hx
call compSpComment m, '*'
end
if tab \== '' then
aClass = classNew('n* Ass u' substr(tab, 3))
res = ''
isFirst = 1
do while scanReadNl(s)
do forever
call compSpNlComment m, '*'
s1 = compStmt(m)
if s1 == '' then
leave
res = res';' comp2code(m, ';'s1)
last = 's'
end
if pos(scanLook(s, 1), '/!}') > 0 then
leave
do qx=1
bx = m.s.pos
s1 = compExpr(m, 'w', '=')
if compIsEmpty(m, s1) then
leave
ex = m.s.pos
if ex <= bx then
return scanErr(s, 'colExpr backward')
do hy=1 to hx while bx >= h.hy.end
end
hz = hy+1
if hz <= hx & ex > h.hz.beg then
call scanErr s, 'value on hdr' h.hy 'overlaps' h.hz
else if hy > hx | bx >= h.hy.end | ex <= h.hy.beg then
call scanErr s, 'value from' bx 'to' ex ,
'no overlap with header' h.hy
if qx > 1 then
nop
else if isFirst then do
res = res"; call envWithNext 'b', '"aClass"'"
isFirst = 0
end
else
res = res"; call envWithNext"
res = res"; call envPut '"h.hy"'," comp2Code(m, "-"s1)", 1"
call compSpComment m, '*'
end
end
if isFirst then
return res
else
return '#' res"; call envWithNext 'e'"
endProcedure compassTab
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
sp = 0
co = 0
do forever
if scanVerify(s, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else if xtra == '' then
leave
else if \ scanLit(s, xtra) then
leave
else do
co = 1
m.s.pos = 1+length(m.s.src)
end
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/**** small helper routines ******************************************/
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
if pos(' ', ex) < 1 & pos('COMP.AST.', ex) > 0 then do
a = substr(ex, pos('COMP.AST.', ex))
a = compAstAftOp(m, a)
if m.a.type = 'block' then
return 0 /* m.a.0 == 0 */
else
return m.a.text == ''
end
e1 = word(ex, 1)
return ex = '' | verify(e1, 'ec', 'm') > 0
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, tp
n = mNew('COMP.AST')
m.n.type = tp
if wordPos(tp, 'block') > 0 then do
do cx=1 to arg()-2
m.n.cx = arg(cx+2)
end
m.n.0 = cx-1
end
else do
m.n.text = arg(3)
m.n.0 = 0
end
m.a.isAnnotated = 1
return n
endProcedure compAST
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if ops == '' then
return a
if pos('COMP.AST.', a) < 1 then
return ops || a
if m.a.type = 'ops' then do
m.a.text = ops || m.a.text
return a
end
n = compAst(m, 'ops', ops)
call mAdd n, a
return n
endProcedure compAstAddOp
/*--- return the first AST after the operand chain
put the operands into m.m.astOps ---------------------------*/
compASTaftOp: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return ''
do while m.a.type == 'ops'
m.m.astOps = m.a.text || m.m.astOps
a = m.a.1
end
return a
endProcedure compASTAftOpType
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.type == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
/*--- return the code for an AST with operand chain trg --------------*/
compAst2Code: procedure expose m.
parse arg m, a, aTrg
if pos(' ', a) > 0 | \ abbrev(a, 'COMP.AST.') then
return comp2Code(m, aTrg || a)
if \ abbrev(a, 'COMP.AST.') then
call err 'bad ast' a
do while m.a.type == 'ops'
aTrg = aTrg || m.a.text
a = m.a.1
end
trg = compAstOpsReduce(m, aTrg)
if m.a.type == translate(right(trg, 1), ';', '@') then do
if length(trg) == 1 then do
if pos(trg, ';@') > 0 then
return 'do;' m.a.text ';end'
else
return m.a.text
end
else
return compAST2Code(m, a, left(trg, length(trg)-1))
end
if m.a.type == 'block' then do
op = right(trg, 1)
tLe = left(trg, length(trg)-1)
call compASTAnnBlock m, a
if pos(m.a.maxKind, '.-<') > 0 & pos(op, '.-|?') > 0 then do
if m.a.0 = 1 then do
o1 = if(op=='-', '-', '.')
r = compAst2Code(m, m.a.1, o1)
r = compC2C(m, o1, compAstOpsReduce(m, tLe||o1), r)
if pos(op, '.-<') > 0 then
return '('r')'
else
return r
end
if m.a.0 = 0 & op == '?' then
return compC2C(m, '.', compAstOpsReduce(m, tLe'.'))
if op == '-' then do
cd = ''
do cx = 1 to m.a.0
cd = cd '('compAst2Code(m, m.a.cx, '-')')'
end
return compC2C(m, '-', trg, substr(cd, 2))
end
call scanErr m.m.scan, 'bad block cardinality' aTrg
end
cd = ''
do cx = 1 to m.a.0
cd = cd';' compAst2Code(m, m.a.cx, ';')
end
if right(trg, 1) == '@' then
trg = overlay(';', trg, length(trg))
return compC2C(m, ';', trg, 'do;' cd'; end')
end
else if m.a.type == ';' then do
return compC2C(m, ';', trg, m.a.text)
if right(trg, 1) == '-' then
return compAst2Code(m, "- o2String('"oRunner(m.a.text)"')",
, trg)
if right(trg, 1) == '<' then
return compAst2Code(m, "< o2File('"oRunner(m.a.text)"')",
, trg)
end
else if m.a.type == ':' then do
if m.a.0 = 0 then
call mAdd a, 'call envPushWith', 'call envPopWith'
return compC2C(m, ';', trg,
, 'do;' m.a.1';' m.a.text';' m.a.2'; end')
end
call scanErr m.m.scan, 'implement type' m.a.type 'for' a 'trg' trg
endProcedure compAst2Code
/*--- do a chain of code transformations
from code of kind fr by opList
op as from kind operand
= constant -
- rexx string Expr cast to string/ concat file/output
. rexx object Expr cast to object
< rexx file Expr cast to file
; rexx Statements execute, write obj, Str
@ - cast to ORun, run an obj, write file
| - extract exactlyOne
? - extract OneOrNull
----------------------------------------------------------------------*/
compC2C: procedure expose m.
parse arg m, fr, opList, code
oldCode = fr':' code '==>' opList '==>'
do tx=length(opList) by -1 to 1
to = substr(opList, tx, 1)
if fr == to then
iterate
nn = '||||'
if to == '-' then do
if fr == '=' then
nn = quote(code)
else if abbrev(fr code, '. envGetO(') then
nn = 'envGet(' || substr(code, 9)
else if fr == ';' then
nn = "o2String('"oRunner(code)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("code")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(code))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('code')'
else if fr == '<' then
nn = code
else if fr == ';' then
nn = quote(oRunner(code))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' code
else if fr == '<' then
nn = 'call pipeWriteAll' code
else if fr == ';' then
nn = code
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(code)
else if fr == '-' then
nn = 'call out' code
else if fr == '.' | fr == '<' then
nn = 'call outO' code
end
else if to == ':' then do
if fr == '=' then
nn = quote(code)
else
nn = code
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('code')'
else if fr == '=' then
nn = "file("quote(code)")"
else if fr == '.' then
nn = 'o2File('code')'
else if fr == ';' then
nn = 'o2File('oRunner(code)')'
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then
nn = 'fileSingle('code if(to == '|','', ", ''")')'
else if fr == '@' | fr == ';' then
/* ???wkTst optimize: do it directly */
nn = compC2C(m, fr, to'<', code)
to = '.'
end
if nn == '||||' then
return scanErr(m.m.scan,
,'compC2C bad fr' fr 'to' to 'list' opList)
fr = to
code = nn
end
return code
endProcedure compC2C
/*--- reduce a chain of operands -------------------------------------*/
eliminate duplicates and identity transformations ----------*/
compAstOpsReduce: procedure expose m.
parse arg m, ops
ki = ops
ki = space(translate(ops, ' ', 'e('), 0)
fr = ';<; <;< -.- <@<'
to = '; < - < '
fr = fr '== -- .. << ;; @@ @('
to = to '= - . < ; @ (@'
wc = words(fr)
do until ki = oldKi
oldKi = ki
do wx=1 to wc
do forever
wf = word(fr, wx)
cx = pos(wf, ki)
if cx < 1 then
leave
ki = left(ki, cx-1) || word(to, wx) ,
|| substr(ki, cx+length(wf))
end
end
end
return ki
endProcedure compASTOpsReduce
/*--- annotate a block if necessary ----------------------------------*/
compASTAnnBlock: procedure expose m.
parse arg m, a
if m.a.isAnnotated == 1 then
return
mk = ''
do cx=1 to m.a.0
c = m.a.cx
if pos(' ', c) > 0 | \ abbrev(c, 'COMP.AST.') then
ki = left(c, 1)
else if \ abbrev(c, 'COMP.AST.') then
return scanErr(m.m.scan, 'bad ast' c 'parent' a) /0
else
call scanErr m.m.scan, 'implement kind of' c 'type' m.c.type
if pos(ki, '=-.<;@:|') < 1 then do
if pos(ki, 'el0') < 1 then
call err 'bad kind' ki
end
else if mk == '' | pos(ki, '=-.<;@:|') > pos(mk, '=-.<;@:|') then
mk = ki
end
m.a.maxKind = mk
m.a.isAnnotated = 1
return
endProcedrue compASTAnnBlock
/**** old code generator ***********************************************
plan is to replace it with AST ******************************/
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
if expr == '' & pos(' ', ki) < 1 & pos('COMP.AST.', ki) > 0 then do
cx = pos('COMP.AST.', ki)
return compAst2Code(m, substr(ki, cx), left(ki, cx-1))
end
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 | (to == '*' & fr == '*') then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
toBef = to
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' | fr == '<' then
nn = 'call outO' expr
else if fr == '#' then
nn = 'call envPushWith ;'expr'; call envPopWith'
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then do
nn = 'fileSingle('expr if(to == '|','', ", ''")')'
to = '.'
end
else if fr == '@' | fr == ';' then do
to = to'<'fr
nn = expr
end
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' toBef 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ @( $l $0 @#'
to.2 = '= - . < ; ( (- (. (; < ; @ @ (@ $ $ ;#'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; ;<( <(; @(- @(l |(l ?(l'
to.3 = ' 0; l; - - . . ; ;< <; ;(- ;(l (|l (?l'
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 then do
if trgt == '|' | trgt == '?' then
return left(m.st.1, 1) comp2Code(m, m.st.1)
else if trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
end
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/* copy comp 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.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
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 scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- 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, onlyIfMatch
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
if onlyIfMatch == 1 then
nx = m.m.pos
else
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 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- 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
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
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
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
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.rdr \== '' then
interpret 'res = ' objMet(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.rdr \== '' then
interpret 'return' objMet(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')
om = objMet(m, 'scanInfo', '')
if om == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' om
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
call classNew "n EditRead u JRW", "m",
, "jRead return editRead(m, var)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m, var
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) ^= 0 then
return 0
m.var = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 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 jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead 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 scanReadIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m, arg(3) ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
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 m
endProcedure scanWinOpts
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
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.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
parse arg m
m.m.atEnd = 'still closed'
call jClose m.m.rdr
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.rdr, 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
call scanWinRead m
if scanVerify(m, ' ') then do
res = 1
iterate
end
else if scanLit(m, '/*') then do
ex = pos('*/', m.m.src, m.m.pos+2)
if ex <= m.m.pos then
return scanErr(m, '*/ missing after /*')
m.m.pos = ex+2
res = 1
end
else do
cl = length(m.m.scanComment)
np = scanWinNlPos(m)
if \ ( cl>0 & m.m.pos+cl <= np & m.m.scanComment ,
== substr(m.m.src, m.m.pos, cl)) then
return res
m.m.pos = np
res = 1
end
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 '\n'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 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, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
endProcedure scanSqlReset
/*--- scan a sql token put class in m.sqlclass:
'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 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = '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.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' 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
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
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 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 m
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'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
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
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.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call mapReset env.vars
m.env.with.0 = 0
call mapReset env.c2w
call mNewArea 'ENV.WICO', '='
m.pipe.0 = 1
m.pipe.1.in = jOpen(oNew('JRWEof'), '<')
m.pipe.1.out = jOpen(oNew('JSay'), '>')
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput Parent saY Newcat File, Appendtofile
psf| parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO, aI
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if pos(oc, 's|fp') > 0 then do
call jClose m.pipe.ax.in
if oc == 'p' then
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
else if oc == '|' then
m.pipe.ax.in = jOpen(oOut, '<')
else if oc == 'f' then do
if arg() <= 3 then
m.pipe.ax.in = jOpen(o2file(aI), '<')
else do
ct = jOpen(Cat(), '>')
do lx = 3 to arg()
call jWriteAll ct, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(ct), '<')
end
end
else if arg() <= 3 then
m.pipe.ax.in = jOpen(jBuf(aI), '<')
else do
bu = jOpen(jBuf(), '>')
do lx = 3 to arg()
call jWrite bu, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(bu), '<')
end
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then
call err 'implement' substr(opts, ox) 'in pipe' opts
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
envIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(env.vars, na)
endProcedure envIsDefined
envPushWith: procedure expose m.
parse arg obj, cl, fn, elCl
tos = m.env.with.0 + 1
m.env.with.0 = tos
m.env.with.tos.fun = fn
m.env.with.tos.muElCl = ''
if fn == '' then do
call envSetWith obj, cl
return
end
if cl == '' then
cl = objClass(obj)
if fn == 'as1' then do
call envSetWith obj, cl
m.env.with.tos.muElRef = m.cl.valueCl \== '',
& m.cl.valueCl \== m.class.classV
if m.env.with.tos.muElRef then
m.env.with.tos.muElCl = m.cl.valueCl
else
m.env.with.tos.muElCl = cl
return
end
else if fn \== 'asM' then
call err 'bad fun' fn
ff = oClaMet(cl, 'oFlds') /*just be sure it's initialised */
if m.cl.stemCl == '' then
call err 'class' className(cl) 'not stem'
cc = m.cl.stemCl
isRef = m.cc == 'r'
m.env.with.tos.muElRef = isRef
if m.cc \== 'r' then
m.env.with.tos.muElCl = cc
else if elCl \== '' then
m.env.with.tos.muElCl = elCl
else if m.cc.class == '' then
call err 'elCl null for envPushWith('obj ','cl ','multi', ...)'
else
m.env.with.tos.muElCl = m.cc.class
m.env.with.tos.class = ''
m.env.with.tos.muCla = cl
m.env.with.tos.muObj = obj
return
endProcedure envPushWith
envSetWith: procedure expose m.
parse arg obj, cl
if cl == '' & obj \== '' then
cl = objClass(obj)
tos = m.env.with.0
m.env.with.tos = obj
m.env.with.tos.class = cl
return
endProcedure envSetWith
envWithObj: procedure expose m.
tos = m.env.with.0
if tos < 1 then
call err 'no with in envWithObj'
return m.env.with.tos
endProcedure envWithObj
envAccPath: procedure expose m. m cl
parse arg pa, stop, nllNw
nullNew = nllNw == 1
dx = verify(pa, m.class.cPath, 'm')
if dx = 0 then do
n1 = pa
p2 = ''
end
else do
n1 = left(pa, dx-1)
p2 = substr(pa, dx)
end
wCla = ''
do wx = m.env.with.0 by -1 to if(stop==1, m.env.with.0, 1)
wCla = m.env.with.wx.class
if symbol('m.wCla.f2c.n1') == 'VAR' then
return oAccPath(m.env.with.wx, pa, m.env.with.wx.class)
end
if stop == 1 then
return 'no field' n1 'in class' className(wCla)
vv = mapValAdr(env.vars, n1)
if vv \== '' then
if p2 == '' then
return oAccPath(vv, '', m.class.classR)
else
return oAccPath(vv, '|'p2, m.class.classR)
else if nullNew & p2 == '' then
return oAccPath(mapValAdr(env.vars, n1,'a'), p2,m.class.classR)
else
return 'undefined variable' pa
endProcedure envAccPath
envWithNext: procedure expose m.
parse arg beEn, defCl, obj
tos = m.env.with.0
if tos < 1 then
call err 'envWithNext with.0' tos
st = m.env.with.tos.muObj
if beEn == 'b' then do
if m.env.with.tos.fun == 'asM' then
m.st.0 = 0
if m.env.with.tos.muElCl == '' then
m.env.with.tos.muElCl = defCl
end
else if m.env.with.tos.fun == 'asM' then
m.st.0 = m.st.0 + 1
else if m.env.with.tos.fun == '' then
call outO m.env.with.tos
else if beEn = '' then
call err 'no multi allowed'
if beEn == 'e' then
return
if m.env.with.tos.fun == 'as1' then do
if m.env.with.tos == '' then
call err 'implement withNext null'
return
end
/* if obj \== '' then do
if \ m.env.with.tos.muElRef then
call err 'obj but not ref'
m.nn = obj
call envSetWith obj
end
*/
if m.env.with.tos.fun == '' then do
call envSetWith oNew(m.env.with.tos.muElCl)
return
end
nn = st'.' || (m.st.0 + 1)
if m.env.with.tos.muElRef then do
m.nn = oNew(m.env.with.tos.muElCl)
call envSetWith m.nn
end
else do
call oClear oMutate(nn, m.env.with.tos.muElCl)
call envSetWith nn
end
return
endProcedure envWithNext
envPushName: procedure expose m.
parse arg nm, multi, elCl
res = envAccPath(nm, , 1)
if res \== 1 then
return err(res 'in envPushName('nm',' multi')')
do while m.cl == 'r'
if m.m == '' then do
res = oRefSetNew(m, cl)
if res \== 1 then
call err res 'in envPushName('nm',' multi')'
end
m = m.m
cl = objClass(m)
end
call envPushWith m, cl, multi, elCl
return
endProcedure envPushName
envNewWiCo: procedure expose m.
parse arg co, cl
k1 = strip(co cl)
n = mapGet('ENV.C2W', k1, '')
if n \== '' then
return n
k2 = k1
if co \== '' then do
k2 = strip(m.co.classes cl)
n = mapGet('ENV.C2W', k2, '')
end
k3 = k2
if n == '' then do
cx = wordPos(cl, m.co.classes)
if cx > 0 then do
k3 = space(subWord(m.co.classes, 1, cx-1),
subWord(m.co.classes, cx+1) cl, 1)
n = mapGet('ENV.C2W', k3, '')
end
end
if n == '' then
n = envNewWico2(co, k3)
call mapAdd 'ENV.C2W', k1, n
if k2 \== k1 then
call mapPut 'ENV.C2W', k2, n
if k3 \== k2 & k3 \== k1 then
call mapPut 'ENV.C2W', k3, n
return n
endProcedure envNewWiCo
envNewWiCo2: procedure expose m.
parse arg co, clLi
n = mNew('ENV.WICO')
if co == '' then
m.n.level = 1
else
m.n.level = m.co.level + 1
m.n.classes = clLi
na = ''
do cx = 1 to words(clLi)
c1 = word(clLi, cx)
na = na className(c1)
do qx=1 to 2
ff = c1 || word('.FLDS .STMS', qx)
do fx = 1 to m.ff.0
fn = m.ff.fx
if fn == '' then
iterate
fn = substr(fn, 2)
m.n.f2c.fn = cx
end
end
end
m.n.classNames = space(na, 1)
return n
endProcedure envNewWiCo2
envPopWith:procedure expose m.
tos = m.env.with.0
m.env.with.0 = tos - 1
return
endProcedure envPopWith
envGet: procedure expose m.
parse arg na
res = envAccPath(na)
if res == 1 then
res = oAccStr(m, cl)
if res == 1 then
return str
return err(res 'in envGet('na')')
endProcedure envGet
envGetO: procedure expose m.
parse arg na, opt
res = envAccPath(na, , opt == '-b')
if res == 1 then
res = oAccO(m, cl, opt)
if res == 1 then
return ref
return err(res 'in envGetO('na')')
endProcedure envGetO
envPutO: procedure expose m.
parse arg na, ref, stop
res = envAccPath(na, stop, 1)
if res == 1 then
res = ocPutO(m, cl, ref)
if res = 1 then
return ref
return err(res 'in envPutO('na',' ref',' stop')')
endProcedure envPutO
envPut: procedure expose m.
parse arg na, va, stop
res = envAccPath(na, stop , 1)
if res == 1 then
res = ocPut(m, cl, va)
if res == 1 then
return va
return err(res 'in EnvPut('na',' va',' stop')')
endProcedure envPut
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call envPutO na, res
return 1
endProcedure envReadO
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
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.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
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
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
fileSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in fileSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in fileSingle('m')'
return res
endProcedure fileSingle
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
call classAddMet m.class.classV, 'o2File return file(m.m)'
call classAddMet m.class.classW, 'o2File return file(substr(m,2))'
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class.classV
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.m.defDD = 'CAT*'
m.fileTso.buf = m.fileTso.buf + 1
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead 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 == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('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)
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
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 fileTsoClose
fileTsoRead: 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
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = oNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
interpret fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, cx, tBef, tAft, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar == 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
call fTabReset ff, tBef, tAft
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return
endProcedure sqlFTabReset
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
if f1 == '' then
f1 = m.m.set.sx.fmt
if l1 == '' then
l1 = m.m.set.sx.label
end
end
cx = m.m.sqlX
kx = sqlCol2kx(cx, c1)
if kx == '' then
call err 'colName not found' c1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
if f1 \== '' then do
if right(f1, 1) \== ' ' then
f1 = f1' '
return fTabAdd(m, c1 aDone, f1, l1)
end
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f2 = m.m.sql2fmt.ty
if f2 == 'c' then
f2 = '%-'min(le, m.m.maxChar)'C'
else if f2 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f2 = '%'pr'.'de'i'
end
if \ abbrev(f2, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f2
return fTabAdd(m, c1 aDone, f2' ', l1)
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
call sqlRxFetchVars cx
do kx=1 to m.sql.cx.d.sqlD
c1 = m.sql.cx.col.kx
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, m.sql.cx.col.kx
end
return
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 100, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 100, '-')
return
endProcedure sqlFTabCol
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
tstCatTb:
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call tstEnd t
return
endProcedure tstCatTb
sqlCatIni: procedure expose m.
if m.sqlCat_ini == 1 then
return
m.sqlCat_ini = 1
m.sqlCat_rbaF = '%-20H'
return
endProcedure sqlCatIni
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabReset ft, cx, 'c 1', '1 c', 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'RBA1' , m.sqlCat_rbaF
call FTabSet ft, 'RBA2' , m.sqlCat_rbaF
call FTabSet ft, 'START_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlPreOpen cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlRxClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAdd ft, substr(tt,length(sep)+1), substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql.conDbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
lx = 1
plus = 0
stops = '/*-*/ (select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
if substr(sq, nx, 5) == '/*-*/' then do
sq = delStr(sq, nx, 5)
plus = plus + 1
cx = nx
iterate
end
call out int || substr(sq, lx, nx-lx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
lx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatCopy: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = "select substr('' ||" al".instance || case" ,
"when" al".instance = 1 and s.clone = 'N' then ''" ,
"when s.clone = 'N' then 'only'" ,
"when s.instance =" al".instance then 'base'" ,
"else 'clone' end, 1, 6) insTxt" ,
", icType || case icType" ,
"when 'A' then '=alter'" ,
"when 'B' then '=rebuiIx'" ,
"when 'C' then '=create'" ,
"when 'D' then '=checkData'" ,
"when 'E' then '=recovToCu'" ,
"when 'F' then '=fulCopy'" ,
"when 'I' then '=incCopy'" ,
"when 'J' then '=comprDict'" ,
"when 'L' then '=sql'" ,
"when 'M' then '=modifyRec'" ,
"when 'P' then '=recovPIT'" ,
"when 'Q' then '=quiesce'" ,
"when 'R' then '=loaRpLog'" ,
"when 'S' then '=loaRpLoNo'" ,
"when 'T' then '=termUtil'" ,
"when 'V' then '=repairVer'" ,
"when 'W' then '=reorgLoNo'" ,
"when 'X' then '=reorgLog'" ,
"when 'Y' then '=loaRsLoNo'" ,
"when 'Z' then '=loaLog'" ,
"else '=???' end icTyTx" ,
',' al'.*' ,
'from' tkrTable( , tb, 't') 'join sysibm.sysTableSpace s' ,
'on' al'.dbName = s.dbName and' al'.tsName = s.name' ,
'where' wh 'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, dbName , '%-8C', 'db'
call sqlFTabAdd ft, tsName , '%-8C', 'ts'
call sqlFTabAdd ft, dsNum , '%4i', 'part'
call sqlFTabAdd ft, insTxt , '%6C', 'instan'
call sqlFTabAdd ft, icTyTx , '%-11C', 'icType'
call sqlFTabAdd ft, sType
call sqlFTabAdd ft, oType
call sqlFTabAdd ft, jobName
call sqlFTabAdd ft, timestamp
call sqlFTabAdd ft, dsName
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatCOPY
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
sqlCatRec: procedure expose m.
parse arg ft, tb, pWh, ord
wh = sqlWhereResolve(pWh)
al = m.tb.alias
vw = catRecView('cat')
if m.recView.unl then
sq = "select fun, recover, lok || ' ' || load loadText"
else
sq = "select case when left(recover, 2) = 'ok'",
"then 'r' else '?' end fun" ,
", '' stage, 'noXDocs' loadText" ,
", '' unlTst, '' unl, '' punTst, '' pun"
sq = sq", lPad(strip(basPa), 4) || basTy|| char(basTst) basPTT",
", ( select case when count(*) <> 1" ,
"then '|' || count(*) || 'tables'",
"else max(strip(creator) ||'.'|| name) end",
"/*-*/from sysibm.sysTables t" ,
"/*-*/where t.dbName =" al".db" ,
"and t.tsName="al".ts and type not in ('A', 'V')) tb",
"," al".*",
"from" vw al,
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, db , '%-8C', 'db'
call sqlFTabAdd ft, ts , '%-8C', 'ts'
call sqlFTabAdd ft, pa , '%4i', 'part'
call sqlFTabAdd ft, insTxt , '%-5C', 'insta'
call sqlFTabAdd ft, fun , '%-2C', 'fun'
call sqlFTabAdd ft, stage , '%-2C', 'sta'
call sqlFTabAdd ft, recover , '%-7C', '?recov?'
call sqlFTabAdd ft, basPTT , '%-18C','part copytime'
call sqlFTabAdd ft, loadText , '%-70C', '?load?'
call sqlFTabAdd ft, unlTst , '%-19C', 'unloadTime'
call sqlFTabAdd ft, unl , '%-44C', 'unloadDSN'
call sqlFTabAdd ft, punTst , '%-19C', 'punchTime'
call sqlFTabAdd ft, pun , '%-44C', 'punch'
call sqlFTabAdd ft, 'TB' , '%-40C', 'table'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatRec
sqlWhereResolve: procedure expose m.
parse arg wh
wh = strip(wh)
l1 = pos('(', wh)
l2 = pos('(', wh, l1+1)
l3 = pos('(', wh, l2+1)
r1 = pos(')', wh)
r2 = pos('FROM', translate(wh))
if r2 <= 0 then
if pos('SELECT', translate(wh)) < 1 then
return wh
else
call err 'select without from in where:' wh
if l1 <= 0 | l2 <= 0 | r1 <= 0 then
call err 'bad missing first 2 brackets where:' wh
if l1 <> 1 | r1 > l2 then
call err 'bad first bracket pair in where:' wh
if l2 >= r2 | (l3 <= r2 & l3 > 0) then
call err 'bad second bracket / from in where:' wh
if translate(strip(substr(wh, r1+1, l2-r1-1))) \== 'IN' then
call err 'in missing in where:' wh
li = translate(substr(wh, 2, r1-2), ' ', ',')
ci = substr(wh, l2+1, r2-l2-1)
if translate(word(ci, 1)) \== 'SELECT' then
call err 'missing select in where:' wh
ci = subWord(ci, 2)
cj = translate(ci, ' ', ',')
c0 = words(cj)
if c0 <> words(li) then
call err 'list 1&2 not equal len in where:' wh
do cx=1 to words(cj)
lA = word(cj, cx)
c.cx = translate(substr(lA, pos('.', lA) + 1))
l.cx = word(li, cx)
end
call sql2St substr(wh, l2+1, length(wh)-l2-1),
'group by' ci 'order by' ci, rr
c1 = c.1
c2 = c.2
r = ''
do rx=1 to m.rr.0
if rx = 1 then
ex = 0
else do
ry = rx - 1
do ex=1 to c0
cA = c.ex
if m.rr.rx.cA <> m.rr.ry.cA then
leave
end
ex = ex-1
if ex < c0 - 1 then
r = r copies(')', c0-ex)
end
do dx=ex+1 to c0
cA = c.dx
if dx = ex + 1 then
r = r 'or' left('(', dx < c0)
else
r = r 'and ('
r = r l.dx "= '"m.rr.rx.cA"'"
end
end
return substr(r, 4) copies(copies(')', c0), c0>1)
endProcedure sqlWhereResolve
catRecView: procedure expose m.
parse arg m
m.recView.unl = wordPos(m.m.dbSy, 'DBOF DVBP') > 0
if \ m.recView.unl then
return 'oa1p.vqz005Recover'
call sql2St "select punTst tst, err" ,
", case when punTst < current timestamp - 1 hour" ,
"then 1 else 0 end att" ,
"from oa1p.tQZ005TecSvUnload" ,
"where stage = '-r'", recView
call out ' '
t = 'Recovery Unloads aus oa1p.tQZ005TecSvUnload'
if m.m.dbSy = 'DVBP' then
call out ' ELAR XB' t
else
call out ' EOS und eRet (XC, XR)' t
t = 'refresh='m.recView.1.tst 'err='m.recView.1.err
if m.recView.0 < 1 then
call out ' Achtung: ist leer'
else if m.recView.0 > 1 then
call out ' Achtung: zuviele ('m.recView.0') -r rows'
else if m.recView.1.att = 1 then
call out ' Achtung: älter 1h:' t
else
call out ' ' t
call out ' cx -ru ... für refresh unload'
call out ' '
return 'oa1p.vqz005RecovLoad'
endProcedure catRecView
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
',' sqlLrsn2tst('rba1') 'rba1Tst' ,
',' sqlLrsn2tst('rba2') 'rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , m.sqlCat_rbaF
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , m.sqlCat_rbaF
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqllrsn2tst: procedure expose m.
parse arg f /* sql fails in v10 without concat | */
return "timestamp(case when length("f") = 6 then" f "|| x'0000'" ,
"when substr("f", 1, 4) = x'00000000' then" ,
"substr("f" || X'000000000000', 5, 8)" ,
"else substr("f" || X'00000000', 2, 8) end)"
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , m.sqlCat_rbaF ,
, 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFlds(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = substr(m.ff.fx, 2)
v = m.m.f1
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.mPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 | vx = 0 then do
l1 = min(60, vx)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/* copy sqlDiv end **************************************************/
/* copy db2Cat begin **************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'", ,'')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq, colName, ordering" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlPreOpen 1, sql
res = ''
do kx=1 while sqlFetchInto(1, ':sq, :col, :ord')
if sq \= kx then
call err 'expected' kx 'but got colSeq' sq ,
'in index' cr'.'ix'.'col
res = res || strip(col) || translate(ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlPreOpen 1, sql
pr = ' '
do kx=1 while sqlFetchInto(1, ':na, :ty, :nu, :de, :nn')
/* say kx na ty nu de 'nn' nn */
if pos('CHAR', ty) > 0 then
dv = "''"
else if pos('INT' ,ty) > 0 | wordPos(ty, 'REAL FLOAT') > 0 then
dv = 0
else if ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', ty) > 0 then
dv = ty"('')"
else
dv = '???'
if nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if ty = 'ROWID' then do
r = '--'
end
else if nn == 'new' then do
if de = 'Y' then
r = '--'
else if nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if nu = 'Y' | (nu = nn) then
r = ''
else
r = 'coalesce('na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' ty 'in' tCr'.'tTb'.'na
call out r na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end **************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
call jIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlOIni
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
hst = ''
cTy = 'Rx'
end
if m.sql.conType==cTy & m.sqlHost==hst & m.sqlconDbSYs == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
else
m.sql.conDbSys = sys
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conDbSys = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, m.sql.cx.type
if m.sql.cx.type \== '' then
m.sql.cx.type = class4Name(m.sql.cx.type)
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if (sub == '' & m.sql.conDbSys== '') ,
| (sub \== '' & m.sql.conDbSys \== sub) then
call sqlConnect sub
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call sbSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql.sqlHaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then
return sqlMsgLine( , upds, src, coms 'commits')
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.mAlfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%qn %S'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlReset crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec 'describe cursor c'crs 'into :m.sql.'crs'.D'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%qn v, f %s')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = oNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/* copy sqlO end **************************************************/
/* copy sqlC begin ***************************************************
sql interface Compatibility mode
***********************************************************************/
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
m.sql.cx.type = ''
res = sqlPrepare(cx, src, ggRetOk, descOut)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- 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 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
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
/*--- 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
if arg() >= 4 then do
call sqlDescribeInput ggCx
do ggAx=4 to arg()
call sqlDASet ggCx, 'I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx use)
end
else do
ggRes = sqlOpen(ggCx)
end
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlRxClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecStmt:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
if ggAx > 1 then
call sqlDescribeInput ggCx
do ggAx=2 to arg()
call sqlDASet ggCx, 'I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure execStmt
/*--- execute immediate the sql src ----------------------------------*/
/* copy sqlC end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conDbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay 'sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay sqlMsg(sqlCA2rx(sqlCa)), 'w'
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
f = m.sql.cx.type
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
if f \== '' then do
f = f'.FLDS'
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlQCsm begin *************************************************/
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk
return sqlCsmQuery(cx, src, retOk)
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
return sqlCsmFetch(cx, dst)
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
return sqlCsmUpdate(cx, src, retOk)
/*-- execute an sql call statement with outParms and several results--*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
return sqlCsmCall(cx, src, retOk)
/* copy sqlQCsm end *************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlRxClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlRxClose cx
if \ f1 then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if f2 then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlRxFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, retOk
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm 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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd)
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if m.err.ispf then
call adrIsp 'vget wshTsoDD shared', 0 8
else if symbol('m.tso.tsoDD') == 'VAR' then
wshTsoDD = m.tso.tsoDD
else
wshTsoDD = ''
if f == '-' then do
px = wordPos(dd, wshTsoDD)
if px < 1 then
call err 'tsoDD dd' dd 'not used' wshTsoDD
wshTsoDD = strip(subword(wshTsoDD, 1, px-1) ,
subWord(wshTsoDD, px+1))
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'wshTsoDD)
if cx < 1 then
dd = dd'1'
else do
old = word(substr(wshTsoDD, cx), 1)
if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, wshTsoDD) > 0 then
call err 'tsoDD dd' dd 'already used' wshTsoDD
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
call adrIsp 'vPut wshTsoDD shared'
m.tso.tsoDD = wshTsoDD
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
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 j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
else
fmt = '%s%qn %s%qe%q^'fmt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%Qn', m.line)
end
call jClose m
return res || f(fmt'%Qe')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
res = ''
bx = m.m.pos
do forever
call sbUntil m, '"''-/'stop
if sbEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if sbLit(m, ''' "') then do
c1 = m.m.tok
do while \ sbStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call sbChar m, 1
if res <> '' then
return strip(res)
bx = m.m.pos
end
else if \ sbLit(m, '- /') then do
call err 'bad char at' substr(m.m.src, m.m.pos) 'in' m.m.src
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return strip(res)
end
endProcedure jCatSqlNext
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new return jReset("m.class.basicNew", arg, arg2, arg3)",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new return jReset("m.class.basicNew", arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutate m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if oClaInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutate m, 'JBufSR'
else
call oMutate m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutate m, 'JBufSW'
else
call oMutate m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutate m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: 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
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: 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
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
if the parent is class OLazyMet, a methof found there is
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o.ini == 1 then
return
m.o.ini = 1
call mIni
m.o.escW = '!'
m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
call oAddCla m.o.lazyGen
return
endProcedure oIni
/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla
/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
call err 'bad class name' cl 'in oAddCla('cl',' parents')'
if oIsCla(cl) then
call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
do px=1 to words(parents)
if \ oIsCla(word(parents, px)) then
call err word(parents, px) 'is no class' ,
'in oAddCla('cl',' parents')'
end
m.o.cParent.cl = parents
return
endProcedure oAddCla
/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
if \ oIsCla(cl) then
call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
if symbol('m.o.cMet.cl.met') == 'VAR' then
call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
m.o.cMet.cl.met = cont
return
endProcedure oAddMet
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
interpret oClaMet(cl, 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o.escW) then
return m.class.classW
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return oClaInheritsOf(cl, sup)
endProcedure oKindOf
oClaInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
if symbol('m.o.cParent.sup') \== 'VAR' then
sup = class4name(sup)
if cl == sup then
return 1
do sx=1 to words(m.o.cParent.cl)
if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
return 1
end
return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o.escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.o.cMet.ggClass.me') == 'VAR' then
return m.o.cMet.ggClass.me
code = oClaMet(ggClass, me, '---')
if code \== '---' then
return code
else if arg() >= 3 then
return arg(3)
return err('no method' me 'in class' className(ggClass) ,
'of object' m)
endProcedure objMet
oClaMet: procedure expose m.
parse arg cl, me
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
if \ oIsCla(cl) then do
c2 = class4Name(cl, '')
if c2 \== '' & oIsCla(c2) then do
cl = c2
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
end
else do
if arg() >= 3 then
return arg(3)
else
return err('no class' cl 'in oClaMet('cl',' me')')
end
end
code = oLazyMetGen(m.o.lazyGen, cl, me)
do px = 1 to words(m.o.cParent.cl) while code == '---'
code = oClaMet(word(m.o.cParent.cl, px), me, '---')
end
if code == '---' then do
if arg() >= 3 then
return arg(3)
else
return err('no met' me 'in class' cl)
end
m.o.cMet.cl.me = code
return code
endProcedure oClaMet
oLazyMetGen: procedure expose m.
parse arg lg, cl, me
if symbol('m.o.cMet.lg.me') \== 'VAR' then
return '---'
interpret m.o.cMet.lg.me
endProcedure oLazyMetGen
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.o.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
oClaClear: procedure expose m.
parse arg cla, m
interpret "drop cla;" oClaMet(cla, 'oClear')
return m
endProcedure oClaClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
call oClaMet cl, 'oFlds'
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = oNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" oClaMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.class.in2 = 0
call oIni
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
m.class.basicNew = "oMutate(mNew(cl), cl)"
call oAddMet m.o.lazyGen, 'new', "return classGenNew(cl, me)"
call oAddMet m.o.lazyGen,'oClear',"return classGenClear(cl, me)"
call oAddMet m.o.lazyGen,'oFlds',"return classGenFlds(cl, me)"
call oAddMet m.o.lazyGen, 'oCopy', "return classGenCopy(cl, me)"
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classFinish cr
call oClaMet cr, 'oFlds' /* generate flds */
end
m.class.in2 = 1
call oAddMet m.class.classV, 'oCopy', "return oCopyV(m, t)"
call classAddMet m.class.classV, 'o2String return m.m'
call classAddMet m.class.classW, 'o2String return substr(m, 2)'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if isNew & m.class.in2 then
call classFinish n
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
return n
endProcedure classNew
/*--- to the finish for new class cl -------------------------------*/
classFinish: procedure expose m.
parse arg cl, force
call oMutate cl, m.class.class
/* find super and sub classes */
m.cl.sub = ''
sups = ''
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 \== 'u' then
iterate
if wordPos(u1, sups) > 0 then
call err u1 'already in sups' sups': classSuperSub('cl')'
sups = sups u1
if wordPos(m.cl.SUB, cl) > 0 | symbol('m.u1.sub') \== 'VAR' then
call err cl 'is already in' u1'.sub' u1.SUB ,
|| ': classSuperSub('cl')'
m.u1.sub = strip(m.u1.sub cl)
end
m.cl.super = sups
/* add class to o */
call oAddCla cl, sups
if pos(m.cl, 'mfrsv') < 1 then do
allMets = ''
forceMets = ''
do cx=1 to m.cl.0
ch = m.cl.cx
if m.ch == 'm' then do
call oAddMet cl, m.ch.name, m.ch.met
allMets = allMets m.ch.name
end
else if symbol('m.class.forceDown.ch') == 'VAR' then
forceMets = forceMets m.class.forceDown.ch
end
myForce = ''
do fx=1 to words(forceMets)
parse value word(forceMets, fx) with fCla '#' fMet
if wordPos(fMet, allMets) < 1 then do
call oAddMet cl, fMet, m.o.cMet.fCla.fMet
myForce = myForce cl'#'fMet
allMets = allMets fMet
end
end
if myForce \== '' then
m.class.forceDown.cl = strip(myForce)
end
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7)
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
return
endProcedure classFinish
classAddMet: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
call mAdd cl, classNew('m' met code)
call oAddMet cl, met, code
return cl
endProcedure classAddMet
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
classGenNew: procedure expose m.
parse arg cl, met
return "m=" m.class.basicNew";" oClaMet(cl, 'oClear') ";" ,
"return m"
endProcedure classGenNew
classGenFlds: procedure expose m.
parse arg cl, met
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classGenFldsAdd cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
return cl'.FLDS'
endProcedure classGenFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classGenFldsAdd: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classGenFldsAdd(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classGenFldsAdd(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classGenFldsAdd f, m.cl.tx, nm
end
return 0
endProcedure classGenFldsAdd
classGenClear: procedure expose m.
parse arg cl, met
r = ''
call oClaMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
r = r classGenStmt(f1, "m.m~ = '"m.o.escW"';")
else
r = r classGenStmt(f1, "m.m~ = '';")
end
do sx=1 to m.cl.stms.0
r = r classGenStmt(m.cl.stms.sx, "m.m~.0 = 0;")
end
return r
endProcedure classGenClear
classGenStmt: procedure expose m.
parse arg f, st, resWo
isNice = translate(f) == f
resWo = translate(resWo) 'GGFF M'
fDod = '.'f'.'
do wx=1 to words(resWo) while isNice
isNice = pos('.'word(resWo, wx)'.', fDot) < 1
end
if isNice then
return repAll(st, '~', f)
else
return "ggFF = '"substr(f, 2)"';" repAll(st, '~', '.ggFF')
endProceduer classGenAss
classGenCopy: procedure expose m.
parse arg cl, me
r = repAll("if t == '' then t =" m.class.basicNew ";" ,
"else call oMutate t, cl;", 'cl', "'"cl"'")
ff = oClaMet(cl, 'oFlds') /* build code for copy */
do fx=1 to m.cl.flds.0
r = r classGenStmt(m.cl.flds.fx, 'm.t~ = m.m~;', 't')
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == '' then
st = ''
else do
r = r "st = '"substr(nm, 2)"';"
st = '.st'
end
r = r "m.t"st".0 = m.m"st".0;" ,
"do sx=1 to m.m"st".0;" ,
"call oClaCopy '"sc"', m"st".sx, t"st".sx; end;"
end
return r 'return t;'
endProcedure classGenCopy
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class.classV)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '%s%qn%s%qe%q^'fmt
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCatFT
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mDigits = '0123456789'
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || m.mDigits
m.mAlfDot = m.mAlfNum || '.'
m.mBase64 = m.mAlfUC || m.mAlfLC || m.mDigits'+-'
m.mId = m.mAlfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.mPrint = m.mAlfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
verifId: procedure expose m.
parse arg src, extra, sx
if sx == '' then
sx = 1
if pos(substr(src, sx, 1), m.mDigits) > 0 then
return sx
else
return verify(src, m.mId || extra, 'n', sx)
endProcedure verifId
/* copy m end *********************************************************/
/* copy fTab begin ****************************************************/
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
m.m.set.0 = 0
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
return m
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, tx, t1
m.m.generated = ''
m.m.tit.tx = left(m.m.tit.tx, m.m.len) || t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.label = l1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
m.m.cols = m.m.cols c1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' c1
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after c1' c1
m.m.cx.col = c1
m.m.cx.done = aDone \== 0
if l1 == '' then
m.m.cx.label = c1
else
m.m.cx.label = l1
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@'c1 || substr(f1, px)
m.fTabTst.c1 = m.m.cx.label
t1 = f(f1, m.m.cx.label)
if pos(strip(t1), m.m.cx.label) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1))m.m.cx.label,
, length(t1))
m.m.cx.len = length(t1)
call fTabAddTit m, 1, t1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
m.m.len = m.m.len + length(t1)
return m
endProcedure fTabAdd
fTabGenerate: procedure expose m.
parse arg m
f = ''
do kx=1 to m.m.0
f = f || m.m.kx.fmt
end
m.m.fmt = m'.fmtKey'
call fGen f, m.m.fmt
cSta = m.m.tit.0+3
do cEnd=cSta until kx > m.m.0
cycs = ''
do cx=cSta to cEnd
m.m.tit.cx = ''
cycs = cycs cx
end
cx = cSta
ll = 0
do kx=1 to m.m.0 while length(m.m.tit.cx) < max(ll,1)
m.m.tit.cx = left(m.m.tit.cx, ll)m.m.kx.col
cx = cx + 1
if cx > cEnd then
cx = cSta
ll = ll + m.m.kx.len
end
end
m.m.cycles = strip(cycs)
m.m.tit.1 = translate(lefPad(m.m.tit.1, m.m.len), '-', ' ')'---'
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
l = if(m.m.kx.label == m.m.kx.col, , m.m.kx.label)
f = lefPad(l, 10) lefPad(m.m.kx.col, 18)
if length(f) > 29 then
if length(l || m.m.kx.col) < 29 then
f = l || left('', 29 - length(l||m.m.kx.col))m.m.kx.col
else
f = lefPad(strip(l m.m.kx.col), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
fTab: procedure expose m.
parse arg m
call fTabBegin m
do forever
i = inO()
if i == '' then
leave
call out f(m.m.fmt, i)
end
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m
return fTabTitles(m, m.m.titBef)
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f.fmt.ggFmt') == 'VAR' then
interpret M.f.fmt.ggFmt
else
interpret fGen(ggFmt)
endProcedure f
fAll: procedure expose m.
parse arg fmt
do forever
o = inO()
if o == '' then
return
call out f(fmt, o)
end
endProcedure f
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l
if v \== m.sqlNull then
v = c2x(v)
if l >= 0 then
return right(v, l)
else
return left(v, -l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, d
if datatype(v, 'n') then do
if d == '' then
v = format(v, ,0,0)
else
v = format(v, ,d,0)
if abbrev(l, '+') then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > abs(l) then
return right('', abs(l), '*')
end
if l >= 0 then
return right(v, l)
else
return left(v, -l)
endProcedure fI
/*--- format floating point in E notitaion ---------------------------*/
fE: procedure expose m.
parse arg v, l, d, eChar
if eChar == '' then
eChar = 'e'
if \ datatype(v, 'n') then
return left(v, l)
else if l = 7 then
return fEStrip(format(v, 2, 2, 2, 0), 0, 2, 0, 2, eChar)
else if l = 8 then
return fEStrip(format(v, 2, 2, 2, 0), 1, 2, 0, 2, eChar)
else if l < 7 then
call err 'bad width fE('v',' l',' d')'
else if d == '' then
return fEStrip(format(v, 2, l-6, 2, 0), 1, l-6, 0, 2, eChar)
else if l - d - 5 < 1 then
call err 'bad prec fE('v',' l',' d')'
else
return fEStrip(format(v, 2, d, l-d-5, 0), 1, d, 1, l-d-5, eChar)
endProcedure fE
fEStrip: procedure expose m.
parse arg v, mSi, de, eSi, ePr, eChar
parse var v ma 'E' ex
if ex == '' then do
ma = strip(ma, 't')
ex = '+'left('', ePr, 0)
end
if eSi == 0 then do
if abbrev(ex, '+') then
ex = substr(ex, 2)
else if abbrev(ex, '-0') then
ex = '-'substr(ex, 3)
else do
exO = ex
ex = left('-9', ePr, '9')
/* say 'format('ma '* (1E'exO') / (1E'ex'), 2,' de', 0)' */
ma = format(ma * ('1E'exO) / ('1E'ex), 2, de, 0)
end
end
if mSi == 0 then
if abbrev(ma, ' ') then
ma = substr(ma, 2)
else
ma = format(ma, 2, de-1)
r = ma || eChar || ex
if length(r) - length(eChar) <> 2 + mSi + de + eSi + ePr then
call err 'bad fEStrip('v',' mSi',' de',' eSi',' ePr',' eChar ,
|| ') ==>' r 'bad len' length(r)
return r
endProcedure fEStrip
/*--------------------------------------------------------------------
fGen: Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
+ \s a single space
+ \n a newLine
+ \% \@ \\ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character a
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- d or i Signed decimal integer
- e Scientific notation (mantissa/exponent) using e character 3.9265e+2
- E Scientific notation (mantissa/exponent) using E character 3.9265E+2
- f Decimal floating point
- g Use the shorter of %e or %f
- G Use the shorter of %E or %f
- h Characters in hex
- o Unsigned octal 610
- S Strip(..., both)
- u Unsigned decimal integer
- x Unsigned hexadecimal integer
- X Unsigned hexadecimal integer (capital letters)
- p Pointer address
- n Nothing printed. The argument must be a pointer to a signed int, wh
+ % A % followed by another % character will write % to stdout. %
+ Q for iterator first nxt end
Flags:
- - Left-justify within the given field width; Right justification is
- + Forces to precede the result with a plus or minus sign (+ or -)
- (space) If no sign is going to be written, a blank space is inserte
- # Used with o, x or X specifiers the value is preceeded with 0, 0x
force decimalpoint ...
- 0 Left-pads the number with zeroes (0) instead of spaces, where pad
+ = reuse previous input argument
length not implemented
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg src, key
if key == '' then do
qSuf = right(src, 3)
if length(qSuf) == 3 & abbrev(qSuf, '%Q') then
s2 = left(src, length(src) - 3)
else
s2 = src
call fGen s2, s2
if symbol('m.f.fmt.src') == 'VAR' then
return m.f.fmt.src
call err fGen 'format' src 'still undefined'
end
cx = 1
ky = key
do forever
cy = pos('%q', src, cx)
if cy < 1 then do
m.f.fmt.ky = fGenCode(substr(src, cx), 'F.INFO.'ky)
leave
end
m.f.fmt.ky = fGenCode(substr(src, cx, cy-cx), 'F.INFO.'ky)
if substr(src, cy, 3) == '%q^' then do
if substr(src, cy, 5) == '%q^%q' then
cy = cy+3
else if length(src) = cy + 2 then
leave /* do not overrite existing fmt | */
end
if cy > length(src)-2 then
call err 'bad final %q in' src
if substr(src, cy, 3) == '%q^' then
ky = key
else
ky = key'%Q'substr(src, cy+2, 1)
m.f.tit.ky.0 = 0
cx = cy+3
end
if symbol('m.f.fmt.key') == 'VAR' then
return m.f.fmt.key
call sbErr fGen 'format' src 'still undefined'
endProcedure fGen
fGenCode: procedure expose m.
parse arg aS, jj
jx = 0
call sbSrc fGen, aS
ax = 0
cd = ''
do forever
txt = fText()
if txt \== '' then
cd = cd '||' quote(txt, "'")
if sbEnd(fGen) then do
m.jj.0 = jx
if cd \== '' then
return "return" substr(cd, 4)
else
return "return ''"
end
an = ''
af = '-'
if \ sbLit(fGen, '@') then do
ax = ax + 1
end
else do
if sbWhile(fGen, '0123456789') then
ax = m.fGen.tok
else if ax < 1 then
ax = 1
if substr(m.fGen.src, m.fGen.pos, 1) \== '%' then do
call sbLit fGen, '.'
af = fText()
end
end
if \ sbLit(fGen, '%') then
call sbErr fGen, 'missing %'
call sbWhile fGen, '-+'
flags = m.fGen.tok
call sbWhile fGen, '0123456789'
len = m.fGen.tok
siL = len
if len \== '' & flags \== '' then
siL = left(flags, 1)len
prec = ''
if sbLit(fGen, '.') then do
if len == '' then
call sbErr fGen, 'empty len'
call sbWhile fGen, '0123456789'
prec = m.fGen.tok
end
call sbChar fGen, 1
sp = m.fGen.tok
if ax < 3 then
aa = 'ggA'ax
else
aa = 'arg(' || (ax+1) || ')'
if af \== '-' then do
if af \== '' then
af = '.'af
if abbrev(aa, 'ggA') & pos('.GG', af) < 1 ,
& translate(af) == af then
aa = 'm.'aa || af
else
aa = 'mGet('aa '||' quote(af, "'")')'
end
if sp = 'c' then do
pd = word('rigPad lefPad', (pos('-', flags) > 0)+1)
if prec \== '' then
cd = cd '||' pd'(substr('aa',' prec'),' len')'
else
cd = cd '||' pd'('aa',' len')'
end
else if sp = 'C' then do
if prec \== '' then
cd = cd '|| substr('aa',' prec',' len')'
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa", '"siL"')"
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then do
cd = cd "|| fI("aa", '"siL"'"
if prec == '' then
cd = cd')'
else
cd = cd',' prec')'
end
else if sp == 'E' | sp == 'e' then
cd = cd "|| fE("aa"," len"," prec", '"sp"')"
else if sp == 's' then
cd = cd '||' aa
else if sp = 'S' then
cd = cd '|| strip('aa')'
else
call sbErr fGen, 'bad specifier' sp
jx = jx + 1
m.jj.jx.arg = ax
m.jj.jx.name = af
end
endProcedure fGenCode
fText: procedure expose m. ft.
res = ''
do forever
if sbUntil(fGen, '\@%') then
res = res || m.fGen.tok
if \ sbLit(fGen, '\') then
return res
call sbChar fGen, 1
if pos(m.fGen.tok, 's\@%') < 1 then
res = res'\' || m.fGen.tok
else
res = res || translate(m.fgen.tok, ' ', 's')
end
endProcedure fText
/* copy f end *******************************************************/
/* copy sb begin *** scan basic ***************************************/
/*--- start scanning with a new src ----------------------------------*/
sbSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
return m
sbErr: procedure expose m.
parse arg m, txt
call err txt 'lastToken' m.m.tok 'sbPos' m.m.pos':' ,
strip(substr(m.m.src, m.m.pos, 20), 't') 'in' m.m.src
endProcedure sbErr
/*--- return true if at end of src -----------------------------------*/
sbEnd: procedure expose m.
parse arg m
return m.m.pos > length(m.m.src)
/*--- scan n chararcters, atmost to end of src -----------------------*/
sbChar: procedure expose m.
parse arg m, len
prP = m.m.pos
m.m.pos = min(m.m.pos + len, length(m.m.src) + 1)
m.m.tok = substr(m.m.src, prP, m.m.pos -prP)
return m.m.pos > prP
/*--- scan first matching literal ------------------------------------*/
sbLit : procedure expose m.
parse arg m, lits
do lx=1 until substr(m.m.src, m.m.pos, length(l1)) == l1
l1 = word(lits, lx)
if l1 == '' then do
m.m.tok = ''
return 0
end
end
m.m.tok = l1
m.m.pos = m.m.pos + length(l1)
return 1
/*--- scan while in charset ------------------------------------------*/
sbWhile: procedure expose m.
parse arg m, chSet
vx = verify(m.m.src, chSet, 'n', m.m.pos)
if vx = 0 then
vx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, vx-m.m.pos)
m.m.pos = vx
return m.m.tok \== ''
/*--- scan until in charset ------------------------------------------*/
sbUntil: procedure expose m.
parse arg m, chSet
vx = verify(m.m.src, chSet, 'm', m.m.pos)
if vx = 0 then
vx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, vx-m.m.pos)
m.m.pos = vx
return m.m.tok \== ''
/*--- scan until (and over) string End -------------------------------*/
sbStrEnd: procedure expose m.
parse arg m, sep
px = m.m.pos
m.m.tok = ''
do forever
py = pos(sep, m.m.src, px)
if py = 0 then do
m.m.pos = length(m.m.src) + 1
m.m.tok = m.m.tok || substr(m.m.src, px)
return 0
end
m.m.tok = m.m.tok || substr(m.m.src, px, py-px)
px = py + length(sep)
if length(m.m.src) < px + length(sep) - 1 ,
| sep \== substr(m.m.src, px, length(sep)) then do
m.m.pos = px
return 1
end
m.m.tok = m.m.tok || sep
px = px + length(sep)
end
endProcedure sbStrEnd
/* copy sb end *** scan basic ***************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = ''
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
if m.err.eCat <> '' then do
parse source . . ggS3 . /* current rexx */
pTxt = ',error,fatal error,input error,syntax error,warning,'
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
msg = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1) ,
'in' ggS3':' msg
end
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.digits) > 0 then
return 1
else
return verify(src, m.mId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(CA1) cre=2012-11-14 mod=2012-11-14-13.28.45 A540769 ------
/* rexx ----------------------------------------------------------------
call a cs-ca UsaLine Cmd
----------------------------------------------------------------------*/
parse arg a1, a2, a3
parse source . . self .
return caX(self, a1, a2, a3)
}¢--- A540769.WK.REXX(CHARSET) cre=2016-10-24 mod=2016-10-24-21.42.38 A540769 ---
charset
digits 0123456789
lowerCase abcdefghijklmnopqrstuvwxyz
upperCase ABCDEFGHIJKLMNOPQRSTUVWXYZ
remember space tab lf
dots . dot : colon , comma ; semicolon
dot2 | exclam ? question @ at # crossHat
"" quote '' apo `` backApo _ underscore
ops = equal - minus + plus * star
brackets () round ¢! square {} curly <> lt gt
bar / slash \ backslash ¨ bar ¦ brokenBar
$ dollar £ pound % percent & ampersand
~ tilde ^ hat
Umlaut aou äöü klein ÄÖÜ
}¢--- A540769.WK.REXX(CHECKRTS) cre=2011-09-09 mod=2016-02-29-11.52.54 A540769 ---
/* REXX **************************************************************
synopsis: CHECKRTS db fun
db = db2 subsystem
type = TS oder IX
Aufruf von reoCheck, Docu siehe dort
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.RtsReo
history ***************************************************************
09.09.2011 v5.7 alter code eliminiert
*******************************************************************/
parse upper arg ssid type
result = 0
call reoCheck ssid type
if \ datatype(result, 'n') then
result = 0
exit result
}¢--- A540769.WK.REXX(CHKSTART) cre=2015-11-16 mod=2015-11-16-17.48.35 A540769 ---
/* rexx chkStart */
parse arg aa
call errReset
/* parse value 'ANA DSN.DBXDBAF.ANA(WK40300T)' with fun ddl */
say 'chkStart version 1.1'
fun = ''
ofAna = ''
do wx=1 to words(aa)
w1 = translate(word(aa,wx))
if abbrev(w1, 'DBSYS=') then
dbSys = substr(w1, 7)
else if abbrev(w1, 'DDL=') then
ddl = substr(w1, 5)
else if abbrev(w1, 'ANA=') | abbrev(w1, 'REC=') then do
if fun \== '' then
call err 'duplicate clause' w1 'in' aa
fun = left(w1, 3)
ana = substr(w1, 5)
wx = wx+1
tst = tst2db2(word(aa, wx))
end
else if abbrev(w1, 'OF=') then do
if ofAna \== '' then
call err 'duplicate clause' w1 'in' aa
ofAna = substr(w1, 4)
wx = wx+1
ofTst = word(aa, wx)
end
else
call err 'bad clause' w1 'in' aa
end
say 'fun='fun 'dbsys='dbSys 'ddl='ddl
say 'ana='ana 'tst='tst
if fun == 'REC' then do
if ofAna == '' then
call err 'of missing in' aa
say 'ofAna' ofAna ofTst
ofTst = tst2db2(ofTst, 'bad of timestamp in args')
call err 'bad ofTimestamp' ofTst 'in' aa
end
else if fun \== 'ANA' then
call err 'ana or rec missing in' aa
if pos('.', ana) > 0 then
parse var ana anaC '.' anaN
else
parse var ana anaN anaC
if anaN \== dsnGetMbr(ddl) then
call err 'analysis' anaN '<> mbr of' ddl
staF = listFile(start)
say 'start dd ==>' staF
tt = 'DSN.DBY'dbSys'.'left(anaN, 7)'.START'
if staF \== tt then
call err 'dd start' staF '<>' tt
call readDDBegin start
call readDD start, 'M.I.'
call readDDEnd start
say 'start' m.i.0 'lines'
curTst = tst2db2(date('s') time())
do ix=1 to m.i.0 while m.i.ix = ''
end
if ix <= m.i.0 then do
parse var m.i.ix lSt lFu lAn lAnT .
lSt = tst2db2(lSt, 'bad startTst' lSt 'in' ix':' m.i.ix)
if wordPos(translate(lFu), 'ANA REC') < 1 then
call err 'bad fun' lFu 'in' ix':' m.i.ix
if length(lAn) <> 8 | left(lAn, 7) <> left(anaN, 7) then
call err 'bad ana' lAn 'not' left(anaN, 7)'?' 'in' ix':' m.i.ix
lAnt = tst2Db2(lAnT,'bad anaTimstamp' lAnT 'in' ix':' m.i.ix)
say 'last start' lSt 'ana' lAn lAnT
if fun == 'REC' & (ofAna \== lAn | ofTst \== lAnT) then
call err 'recovery on different analysis'
if lSt >= tst then
if tst = lAnT & lAn = anaN then
call err 'start of same analysis without reAnalyse:' ,
ana tst
else
call err 'last start' lSt 'ana' lAn lAnT ,
'was after analysis time' tst 'of' ana
end
m.o.1 = curTst fun anaN tst
if fun == 'REC' then
m.o.2 = ' of' ofAna ofTst
m.o.0 = 1 + (fun = 'REC')
call mAddSt o, i, ix
call writeDDBegin start
call writeDD start, 'M.O.'
call writeDDEnd start
say 'chkStart registered start at' curTst 'ana' anaN tst
exit
tst2db2: procedure expose m.
parse arg i, eMsg
t = 'yz34-56-78-hi.mn.st'
t3 = '34-56-78-hi.mn.st'
j = translate(i, '999999999', '012345678')
if abbrev('999999:999999.9', j, 7) then
return '20'translate(t3'.a' ,
, i || substr('000000.0', length(i)-6), '345678:himnst.a')
else if abbrev('9999-99-99-99.99.99.9999999999', j, 19) then
return i
else if j == '99999999 99:99:99' then
return translate(t, i, 'yz345678 hi:mn:st')
else if j == '99/99/99 99:99' then
return '20'translate(left(t3, 14), i, '56/78/34 hi:mn')'.00'
else if eMsg == '-' then
return '-'
else if eMsg == '' then
call err 'bad timestamp' i
else
call err eMsg
endProcedure tst2db2
listFile: procedure expose m.
parse upper arg fi
sysDSName = '???'
lc = listDsi(fi "file")
if lc = 0 then
return sysDSName
/* else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
*/ else
call err 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedur listFile
/* 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
fmt = '%s%qn%s%qe%q^'fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mDigits = '0123456789'
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || m.mDigits
m.mAlfDot = m.mAlfNum || '.'
m.mBase64 = m.mAlfUC || m.mAlfLC || m.mDigits'+-'
m.mId = m.mAlfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.mPrint = m.mAlfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
verifId: procedure expose m.
parse arg src, extra, sx
if sx == '' then
sx = 1
if pos(substr(src, sx, 1), m.mDigits) > 0 then
return sx
else
return verify(src, m.mId || extra, 'n', sx)
endProcedure verifId
/* copy m 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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 *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- 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 ax=1 to arg()
say ' ' arg(ax)
end
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 *****************************************************/
}¢--- A540769.WK.REXX(CLASS) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ----
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "asString return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "asString return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "oKindOfString return classMet(cl, 'asString', '\-\')" ,
"\== '\-\'" ,
, "oAsString if classMet(cl, 'oKindOfString')" ,
"then return classMet(cl, 'asString');",
"else return 'if arg() >= 2 then return arg(2)" ,
"; else return err(m ''is not a kind of string" ,
"but has class' className(cl)''')'" ,
, "o2String return classMet(cl,'asString','\-\')" ,
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
m.class_S = classNew('n String u', 'm',
, 'asString return m' ,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, "asString return ''",
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
call mPut class_inheritMet'.'m.class_V, 0
call mPut class_inheritMet'.'m.class_W, 0
call mPut class_inheritMet'.'m.class_O, 0
call mPut class_inheritMet'.'m.class_S, 0
call mPut class_inheritMet'.'m.class_N, 0
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0 /* methods directly in cl */
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0 /* inherited methods */
cl = m.aC.cx
if m.cl == 'u' & m.class_inheritMet.cl \== 0 then
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end **************************************************/
}¢--- A540769.WK.REXX(COMP) cre=2016-08-12 mod=2016-08-12-16.03.46 A540769 -----
/* copy comp begin ****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
**********************************************************************/
/***** initialisation ************************************************/
/*--- module initialisation -----------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = m.ut_space
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp_idChars = m.ut_alfNum'@_'
m.comp_wCatC = 'compile'
m.comp_wCatS = 'do withNew with for forWith ct proc arg if else'
m.comp_astOps = m.comp_chOp'!)&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ---------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile one unit of the source with kind ki
and return oRunner with the code -------------------------*/
compile: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
a = ''
if m.m.end \== '' then
call scanNlUntil s, '$#out'
else if ki == '*' then
call scanNlUntil s, '$#'
else
a = compUnit(m, ki, '$#')
if compIsEmpty(m, a, 0) then
return ''
cd = compAst2Rx(m, '!', a)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m, erKi
s = m.m.scan
if erKi \== '' then
if \ scanEnd(s) then
return scanErr(s, 'wsh' compKindDesc(erKi),
"expected: compile stopped before end of input")
call scanClose s
return m
endProcedure compEnd
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '¢-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code -----------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/¢') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause -----------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code --------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAst(m, '¢')
nlLe = 0 /* sophisticated logic using left and right NLs*/
do forever
one = compExprStm1(m, ki, nlLe)
if one == '' then
return compAstFree0(res)
call mAdd res, one
nlLe = scanNl(s)
end
endProcedure compExprStmts
/*--- scan over space comm nl until next
expression or statement and compile it --------------------*/
compExprStm1: procedure expose m.
parse arg m, ki, nlLe
s = m.m.scan
if pos(ki, ':%^') > 0 then do /* statements with $ are ok */
call compSpNlComment m, '*'
if ki \== ':' then do
one = compExpr(m, 's', ki)
if one \== '' then
return one
end
end
else if ki == '@' then do /* rexx statements */
call compSpNlComment m
one = compExpr(m, 's', ki)
if one\ == '' then do
if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
do forever /* scan all continued rexx lines */
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
return compAstFree0(one)
end
end
else do /* statemens need $, nl logic for expr */
do forever /* tricky logic for empty lines */
do forever
sx = m.s.pos
call scanSpaceOnly s
if \ compComment(m) then
leave
nlLe = 0
end
m.s.pos = sx
one = compExpr(m, 'd', ki)
nlRi = scanNL(s, '?')
if one == '' then do
if nlLe & nlRi then
return compAst(m, translate(ki, ';-', '@=') ,
, ,compAst(m,'='))
end
else if m.one.containsD then
return one
if \ nlRi then
leave
nlLe = scanNL(s)
end
end
return compStmt(m, ki)
endProcedure compExprStm1
/*--- compile a single statement ------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compExprStm1(m, ki, 0),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compExprStm1(m, ki, 0),
, 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compExprStm1(m, ki, 0),
, "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'withNew' then do
oldVars = m.m.comp_assVars
m.m.comp_assVars = ''
one = compCheckNN(m, compExprStm1(m, ki, 0), 'after withNew')
r = compAst(m, 'F', 'withNew', '', one,
, compAst(m, '*', '!.'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
m.m.comp_assVars = oldVars
return r
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compExprStm1(m, ki, 0), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
if fu == 'if' | fu == 'else' then do /* unchanged rexx */
call scanBack s, fu
return compExpr(m, 's', '@')
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '¢' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit -----------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '¢' then
stopper = m.comp_chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/**** lexicals *******************************************************/
/*--- skip a comment. return 0 if there is none ---------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments --------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ---------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp_wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp_wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '¢' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ***************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
¢ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ! execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
**********************************************************************/
/*--- create a new AST ----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ---------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST -------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg -------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')!') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '!') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '!' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, '!', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@!)') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,'!', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, '!', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, '!', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, '!', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, '!', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'wshHookComp( ,'args ',in2Buf())')
end
return compAstErr(a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a)
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '¢' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects ---------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp_idChars) > 0 then
if pos(rl, m.comp_idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
}¢--- A540769.WK.REXX(COMPARE) cre=2015-06-19 mod=2015-06-19-21.55.21 A540769 ---
$#@
$=new=A540769.WK.REXX(wsh)
$=old=A540769.WK.REXX(wshCopy)
call readNxBegin new, $new, new
call readNxBegin old, $old, old
lx = 0
do forever
n1 = readNx(new)
o1 = readNx(old)
if n1 == '' | o1 == '' then
leave
lx = lx+1
cx = compare(m.n1, m.o1)
if cx <> 0 then do
say 'line' lx 'diff at' cx
say ' +' substr(m.n1, cx, 60)
say ' -' substr(m.o1, cx, 60)
end
else if length(m.n1) <> length(m.o1) then
say 'line' lx 'len new' length(m.n1) '<>' length(m.o1) 'old'
end
say 'after line' lx 'new' copies('eof', n1 == '') ,
'old' copies('eof', o1 == '')
call readNxEnd new
call readNxEnd old
}¢--- A540769.WK.REXX(CONSUM) cre=2015-04-23 mod=2015-04-24-13.42.57 A540769 ---
/* rexx ****************************************************************
control summary summary
write one line for each control summary
optionally delete empty members
***********************************************************************/
dsnMsk = 'A540769.TMP.RZ2.**.CONSUM'
dsnMsk = 'DSN.ABUB.TECSV.RZZ'
libOut = 'A540769.TMP.TEXV'
libOut = 'DSN.ABUB.TECSV.CONSUM'
call errReset 'h'
call csiOpen dsl, dsnMsk
oldPd = ''
do while csiNext(dsl, dsl)
parse value substr(m.dsl, 15, 18) ,
with '.' rz '.' dbSys '.' . '.' dt '.'
if dt << 'D1404' then do
say 'too old, skipping' m.dsl
iterate
end
pd = iirz2P(rz)iidbSys2c(dbSys)substr(dt, 2, 2)
if pd \== oldPd then do
if oldPd \== '' then
call writeDsn pdSum, m.su., ,1
oldPd = pd
pdSum = libOut'('pd')'
if dsnExists(pdSum) then
call readDsn pdSum, m.su.
else
m.su.0 = 0
end
call oneLib m.dsl
end
if oldPd \== '' then
call writeDsn pdSum, m.su., ,1
exit
oneLib: procedure expose m.
parse arg lib
m.nn.0 = 0
sx = 1
matchOld = 0
do mx=mbrList(mbl, lib) by -1
dsn = lib'('m.mbl.mx')'
say mx dsn
call readDsn dsn, m.ii.
if m.ii.0 = 0 then do
call adrTso "delete '"dsn"'"
say 'deleted empty' dsn
end
else do
if subword(m.ii.1, 2, 2) <> 'Control Summary' then
call err 'bad line' dsn'.1:' m.ii.1
res = word(m.ii.1, 1) word(m.ii.1, 4)
do y = 5 to min(25, m.ii.0) ,
while word(m.ii.y, 2) <> 'sqls,'
end
if word(m.ii.y, 2) <> 'sqls,' ,
| word(m.ii.y, 8) <> 'errors' then
call err 'bad sqls line' dsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'SOX' ,
& word(m.ii.y, 5) <> 'Recoverability/sx' then
call err 'bad SOX line' dsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'Recoverability' then
call err 'bad Recoverability line' dsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
if word(m.ii.y, 5) <> 'other' then
call err 'bad other line' dsn'.'y':' m.ii.y
res = res left(strip(m.ii.y), 49)
y = y + 1
note = copies(m.ii.y,
, abbrev(translate(word(m.ii.y, 1)), 'NOTE'))
rCo = res
res = res left(strip(note), 72) dsn m.ii.0 'lines'
call mAdd nn, res
if m.su.0 = 0 then
nop
else if sx = 1 & word(res, 1) == word(m.su.1, 1) ,
& word(res, 2) >> word(m.su.1, 2) then
nop
else if abbrev(m.su.sx, rCo) & pos(dsn, m.su.sx) > 0 then
sx = sx+1
else do
if sx <> 1 | m.nn.0 <> 1 then
call err 'result of' dsn '=' res ,
'\n <> old result' m.su.sx
do sx=1 to m.su.0 ,
while word(res, 1) == word(m.su.sx, 1) ,
& word(res, 2) << word(m.su.sx, 2)
end
if \abbrev(m.su.sx, rCo) | pos(dsn, m.su.sx) < 1 then
call err 'result of' dsn '=' res ,
'\n not found in old result' sx m.su.sx
sx = sx+1
matchOld = 1
end
end
if mx <= 1 | ( sx > 7 & \ matchOld) then do
if matchOld then do
say 'matchOld ok' dsn
return
end
call mMove su, sx, m.nn.0+1
do nx=1 to m.nn.0
m.su.nx = m.nn.nx
end
return
end
end
endProcedure oneLib
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if tx < fx then
return f(f2'%##e')
res = f(f2'%##a', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res
endProcedure mCatFT
fGenCat: procedure expose m.
parse arg s, ax
do fx=1 ??????? until \ scanLit(s, '%,')
f.fx = fGen(s)
end
if \ scanLit(s, '%)') then
call scanErr s, 'no %) after @fGenCat%('
if \ scanEnd(s) then
call scanErr s, 'mGenCat not at end'
if fx < 2 | f.2 == "''" then
f.2 = fGen(scanSrc(f_u, '%c'))
if fx < 3 then
f.3 = "''"
if fx < 4 then
f.4 = "''"
adr = m.s.src'%'
if f.1 == "''" then
m.f_gen.adr.1 = 'return' f.2
else
m.f_gen.adr.1 = 'return' f.1 '||' f.2
m.f_gen.adr.2 = 'return' f.4
if f.3 == "''" then
return f.2
else
return f.3 '||' f.2
endProcedure fGenCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.mBase64 = m.ut_alfUC || m.ut_alfLc || m.ut_digits'+-'
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 1 S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz m.ii_rz2c.rz m.ii_rz2plex.rz sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db m.ii_db2c.db mbr i
m.ii_mbr2db.mbr = db
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2P: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2plex, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiLazy
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- mbrList with listDS -----------------------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx +1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk ,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
mx = mbr_name.0
end
m.m.0 = mx
return mx
endProcedure mbrList
/* copy dsnList end ************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(CONSUMDS) cre=2015-05-22 mod=2015-07-06-09.51.38 A540769 ---
$#@
$>. fEdit('::v')
$=dbSys = DBOF
$=uTb = OA1P.tQZ005TecSvUnload
m.strt = timestampNow()
call sqlConnect $dbSys
$@% loadCtrl
$@% recPun XC.XC01A1P.A2*.**
$@% recPun XC.XC01A1P.A5*.**
$@% recPun XR.XR01A1P.A2*.**
$@% delInsert
call sqlDisconnect
$proc $@/recPun/
$arg msk
say 'recPun' $msk
call csiOpen cq, $msk
pp = 0
do cx=0
if \ csiNext(cq, cr) then
m.cr = '???'
ly = m.lr.0
parse var m.cr p '.' db '.' ts '.' pa '.' ty '.' ti
if \ abbrev(m.cr, pr) then do
if cx \== 0 then do
call sort lp, lq, '>>='
do lx=1 to m.lr.0
rt = word(m.lr.lx, 1)
do ly=1 to m.lq.0 while rt << m.lq.ly
end
if ly > 1 & (ly > m.lq.0 | rt >>= m.lq.ly) then
ly = ly - 1
if ly < 1 then
$$- '??? punch not found' m.lr.lx
else
$@% recPunPut . m.lr.lx, m.lq.ly
end
say 'recPun' $msk pr cx',' m.lr.0 'recs,' m.lp.0 'punchs'
if m.cr == '???' then do
say 'recPun' $msk cx 'DSNs'
return
end
end
pr = p'.'db'.'ts'.'
m.lp.0 = 0
m.lr.0 = 0
end
if verify(pa, '0123456789', 'n', 2) > 0 | \abbrev(pa,'P') then
$$- 'bad part' pa':' m.cr
if ti == '' then
iterate
else if length(ti) == 8 then
tf = timeLrsn2LZT(timeUniq2Lrsn(ti))
else if translate(ti, 000000000, 123456789) = 'D000000' then
tf = '20'translate('12-34-56', substr(ti, 2), '123456'),
|| '-00.00.00'
else
call err 'bad time' ti 'in' m.cr
if ty == 'SYSPCH' then
call mAdd lp, tf m.cr
else if ty == 'SYSREC' then do
lz = word(m.lr.ly, 2)
if \ abbrev(lz, pr || pa) then
call mAdd lr, tf m.cr
else do
$** say '????? duplicate' tf m.cr 'after' m.lr.ly
if tf << m.lr.ly then
m.lr.ly = m.lr.ly 'dup' ti
else
m.lr.ly = tf m.cr subWord(m.lr.ly, 3),
'dup' substr(word(m.lr.ly, 2),
, lastPos('.', word(m.lr.ly, 2))+1)
end
end
else
$$- '????bad ty' ty':' m.cr
end
$/recPun/
$proc $@/recPunPut/
$arg reTs rec e1, puTs pun, e2
parse value $rec with p '.' db '.' ts '.P' pa '.' ty '.' ti
ee = $e1 $e2
diff = timestampDiff($puTs, $reTs)
if (diff < 0 | diff > 0.4) ,
/*??? & ( diff > 4 | m.lq.ly >> '2015-01-10' ) */ then
ee = ee 'punNotSoon' diff
$$- db ts substr(pa, 2) 'rec' $reTs $rec 'pun' $puTs $pun $*+
copies('error:' ee, ee <> '')
ky = db'.'ts'.'format(pa)
if symbol('m.dsp.ky') <> 'VAR' then
call err ky 'not in ctrl tables'
o = m.dsp.ky
if m.o.unl <> '' then
call err ky 'dup unl:' m.o.unl
m.o.unlTst = $reTs
m.o.unl = $rec
m.o.punTst = $puTs
m.o.pun = $pun
m.o.err = ee
$/recPunPut/
$proc $@/recPunInsert/
$arg reTs rec e1, puTs pun, e2
parse value $rec with p '.' db '.' ts '.P' pa '.' ty '.' ti
err = $e1 $e2
diff = timestampDiff($puTs, $reTs)
if (diff < 0 | diff > 0.25) ,
/*??? & ( diff > 4 | m.lq.ly >> '2015-01-10' ) */ then
err = err 'punNotSoon' diff
$$- db ts substr(pa, 2) 'rec' $reTs $rec 'pun' $puTs $pun $*+
copies('error:' err, err <> '')
info = space(info, 1)
if length(info) > 70 then do
say '??? truncate info' info
info = left(info, 67)'...'
err = err 'truncInfo'
m.cTrunc = m.cTrunc + 1
end
err = space(err, 1)
if length(err) > 70 then do
say '??? truncate err' err
err = left(err, 67)'...'
m.cTrunc = m.cTrunc + 1
end
m.cErr = m.cErr + (err <> '')
call sqlUpdate , 'insert into' $uTb,
"values('"db"', '"ts"'," pa", ' ', '"$reTs"', '"$rec"'" ,
|| ", '"$puTs"', '"$pun"', '', '"err"')"
$/recPunInsert/
$proc $@/loadCtrl/
$<=¢
select t.dbname db, t.tsname ts, p.partition pa
, value(XC106_DOC_STATE, XC406_PART_STATUS, xr106_DOC_STATE
, '-' ) stage
, value(XC106_TS_UPDATE, XC406_UPDATE_TS , xr106_TS_UPDATE
, '${TIME_TST01>}') staUpd
, case when XC106_DOC_STATE is not null then 'TXC106A1'
when XC406_PART_STATUS is not null then 'TXC406A1'
when Xr106_doc_state is not null then 'TXR106A1'
else left(t.dbName, 2) || 'miss'
end staTb
, '${TIME_TST01>}' unlTst, '' unl
, '${TIME_TST01>}' punTst, '' pun
, '' info
, '' err
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC106A1
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(xc106_doc_tabColId, 3, 2)
and xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(xc106_doc_part_no) = p.partition
and xc106_doc_part_no = right('0000' || p.partition, 4)
left join OA1P.TXC406A1
on t.name like 'TXC5%'
and t.name = xc406_table_name
and smallInt(xc406_part_number) = p.partition
and xc406_part_number = right('000' || p.partition, 3)
left join OA1P.Txr106A1
on t.name like 'TXR2%'
and t.name = xr106_doc_tb_name
and smallInt(xr106_doc_part_no) = p.partition
and xr106_doc_part_no = right('000' || p.partition, 3)
where (t.dbName = 'XC01A1P'
AND (t.tsName LIKE 'A2%' or t.tsName LIKE 'A5%' )
AND NOT (t.tsName LIKE 'A500A'))
or (t.dbName = 'XR01A1P' and t.tsName LIKE 'A2%')
order by t.dbName, t.tsName, p.partition
$!
call sqlSel
px = 0
say timestampNow() 'for'
$| $forWith oo $@¢
px = px + 1
m.dsp.px = $oo
k = strip($DB)'.'strip($TS)'.'format($PA)
if symbol('m.dsp.k') == 'VAR' then
call err 'duplicate' $DB $TS $PA
m.dsp.k = $oo
$!
m.dsp.0 = px
say timestampNow() px 'partitions selected'
$/loadCtrl/
$proc $@/delInsert/
call sqlUpdate , 'delete from' $uTb
call sqlUpdatePrepare 7, 'insert into' $uTb,
'values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)'
cUnl = 0
cTru = 0
cErr = 0
$do dx=1 to m.dsp.0 $@¢
o = m.dsp.dx
ii = space(m.o.info, 1)
ee = space(m.o.err , 1)
cUnl = cUnl + (m.o.unl <> '')
cErr = cErr + (ee <> '')
if length(ii) > 70 then do
ii = left(ii, 67)'...'
ee = 'truncInfo' ee
cTru = cTru + 1
end
if length(ee) > 70 then do
ee = left('truncErr' ee, 67)'...'
cTru = cTru + 1
end
call sqlUpdateExecute 7 , m.o.db, m.o.ts, m.o.pa ,
, m.o.stage, m.o.staUpd, m.o.staTb ,
, m.o.unlTst, m.o.unl, m.o.punTst, m.o.pun ,
, ii, ee
$!
now = timestampNow()
call sqlUpdate , "insert into" $uTb ,
"values('', '', -111, 'r', '"m.time_tst01"', 'refresh'" ,
|| ", '"m.strt"', 'refresh begin'" ,
|| ", '"now"', 'refresh end'" ,
|| ", '"m.dsp.0 "parts," cUnl "unloads'" ,
|| ", '"cErr "errors, "cTru "truncates')"
call sqlCommit
say "reload:" m.dsp.0 "parts," cUnl "unloads," ,
cErr "errors," cTru "truncates," ,
"from" m.strt "to" now
$/delInsert/
$#out 20150706 07:46:38
$#out 20150629 10:25:43
$#out 20150625 09:59:28
$#out 20150618 15:32:36
}¢--- A540769.WK.REXX(CONSUMGE) cre=2012-06-20 mod=2016-10-05-17.00.09 A540769 ---
$#@
$*( control summary generator Version 3.1 5.10.16
5.10.16 walter xDoc rzY/Z
15. 9.16 walter remove old code, add comments
16. 6.16 dvbp : 2 TS aus "LOB" Prüfung ausgeschlossen
16. 6.16 dvbp : 13 TS mit > 200 Partitionen ausgeschlossen
22. 4.16 eos stage RD
19. 4.16 fmtBin7, neue xDoc, views .........
18.12.15 cDbaMdl mit ficd/iic mit part 0 etc., $tstDist, xDoc
20.10.15 tos810, copy nur falls seit 4 tagen keine Utility
ddlControl ==> QZT09
24. 9.15 with recover view and unload table for xDocs
4. 5.15 log Discontinuity Delta (timing window ingorieren)
9. 3.15 besenwagen fuer alle DBOF
19.12.14 save nonUser explain tables
3.12.14 fix fetch first only rr2/rq2/dbof, m rz dependent, RQ2 BE
27.11.14 fix define no: aus space statt (falsch) spaceF auslesen
11. 9.14 rz1 raus, rq2 rein, rz?sql raus
18. 8.14 conSum Elar: Fehler in txbc021/s rapportiern ohne absturz
8. 8.14 copyArc: alles neu erstellen, nicht mehr reNamen
18. 7.14 dvbp: 65 TS mit > 200 Partitionen ausschliessen
$*)
$=fun = m $** c=controlSummary QZT00??0 QZT00??1
$** d=ddlControl QZT09??1
$** r=copyArchive QZT10??0 QZT10??1
$** m=ca2 dba Models FICD? IIC? EXCL? STOP?
$** x=einmalAktion
$** 1=new plex naming convention, 0=old Rz naming
$=tstOut =- userid()'.tst.tecSv'
$=tstOut = - $** - out to productive libs, otherwise to this lib
$=tstDist =- 1 & $tstOut <> '-' $** distribute to tst or prod
$=logDisDelta = 10 minutes
$=useLgRn = 0
$=vCr=OA1P
$****************** generate all LCTLs for all rz/dbSys ****************
$= outLib = DSN.SOURCE.TECSV.GEN
$= outAtt = ::f mgmtClas(COM#A069)
if $fun == 'c' then $@¢
$= distMbr = ##conSum control Summary und TecSv LCTLs
$! else if $fun == 'd' then $@¢
$= distMbr = ##ddlCon ddl Control LCTLs
$! else if $fun == 'm' then $@¢
$= outLib = DSN.SOURCE.CADB.CDBAMGEN
$= distMbr = ##dbaMdl ca DBA Models
$! else if $fun == 'r' then $@¢
$= distMbr = ##copyAr copyArchive LCTLs
$! else if $fun == 'x' then $@¢
$= distMbr = ##xxDist einmalAktion
$! else $@¢
call err 'bad fun' $fun
$!
if $tstOut <> '-' then $@¢
$= outLib = $tstOut
$= outAtt = ::f
$!
$= myTst =- f('%t s')
$= funInfo =- subWord($distMbr, 2)
$= distMbr =- word($distMbr, 1)
$=csDist =. jOpen(file($-outLib"("$-distMbr")" $-outAtt), '>')
call jWrite $csDist, $'$#@'
call jWrite $csDist, $'$** wsh script: distribute' $funInfo
call jWrite $csDist, $'$** generiert' $myTst
$=rzOne= $''
if 0 then $@¢
$>. fEdit()
$@% gen rz2 dvbp
$;
call err 'tstEnd'
$!
if 0 then $@¢
$@% gen rz1 dbtf
$@% gen rz1 dvtb
$@% gen rz1 dboc
$@rzEnd
$!
if 1 then $@¢
$@% gen rz2 dbof
$@% gen rz2 dp2g
$@% gen rz2 dvbp
$@rzEnd
$!
if 1 then $@¢
$@% gen rr2 dbof
$@% gen rr2 dp2g
$@% gen rr2 dvbp
$@rzEnd
$!
if 1 then $@¢
$@% gen rq2 dbof
$@% gen rq2 dp2g
$@% gen rq2 dvbp
$@rzEnd
$!
if 1 then $@¢
$@% gen rz4 dbol
$@% gen rz4 dp4g
$@rzEnd
$!
if 1 then $@¢
$@% gen rzx de0g
$@% gen rzx devg
$@% gen rzx dpxg
$@% gen rzx dx0g
$@rzEnd
$!
if 1 then $@¢
$@% gen rzy de0g
$@% gen rzy devg
$@% gen rzy dpyg
$@rzEnd
$!
if 1 then $@¢
$@% gen rzz de0g
$@% gen rzz devg
$@% gen rzz dpzg
$@rzEnd
$!
call jClose $csDist
if $fun == 'm' then $@¢
call jWrite $csDis2, $"$!"
call jClose $csDis2
$!
call adrIsp "view dataset('"$outLib"("$distMbr")')", 4
$****************** generate all LCTLs for one rz/dbSys ****************
$proc $@/gen/
parse upper arg ., rz dbSys
$=rz=- rz
$=rzDsn =- iiRz2Dsn(rz)
$=dbSys=- dbSys
$=dbC =- iiDbSys2C(dbSys)
$** beSave: qc515* every two hours
$=beSave =- dbSys == DBOF & wordPos(rz, 'RZ2 RR2') > 0
$** houseKeeping by eRet/Eos/xBox
$=isElar=- wordPos($dbSys, 'DVBP DEVG') > 0
$** houseKeeping by Elar/Eos/xBox
$=xDocHK =- wordPos($rz'/'$dbSys $*+
, 'RZ2/DBOF RR2/DBOF RZZ/DE0G RZY/DE0G' $*+
'RZ2/DVBP RR2/DVBP RZZ/DEVG RZY/DEVG') > 0
$** tecSv should not save xDoc
$=xDocNS =- $xDocHK | wordPos($rz'/'$dbSys $*+
, 'RQ2/DBOF RQ2/DVBP RZX/DEVG') > 0
$** xDocs Unloads must exist
$=xDocUnl =- $xDocHK & \ ($rz == 'RR2' & $isElar)
if $xDocNS then $@¢
if $isElar then
$= xDocTx = XB docs
else
$= xDocTx = XC/XR docs
$= xDocNoTx = (non $xDocTx)
$= xDocBrTx = ($xDocTx)
if $rz == 'RZ2' & \ $isElar then
$= xDocConSum = $'$$r'
else
$= xDocConSum = $''
$! else $@¢
$= xDocTx = $''
$= xDocBrTx = $''
$= xDocNoTx = $''
$= xDocConSum = $''
$!
if $xDocConSum = '' then
$= xDocConSu2 = - ??? noch nicht in count
else
$= xDocConSu2 = $''
$=isTec =- abbrev($dbSys, 'DP') | ( $dbSys == 'DBOC')
$=p2 =- iirz2p(rz)$dbC
$=job67 = 0$dbC
if word($rzOne, 1) == $rz then
$= rzOne = $rzOne $dbSys
else if $rzOne == '' then do
$= rzOne = $rz $dbSys
call jWrite $csDist, "say '"left("--- distributing" $funInfo,
"to" $rz" ", 65, '-')"'"
end
else
call err 'rz='rz 'dbSys='dbSys 'but rzOne='$rzOne
say 'gen rz='$rz', dbSys='$dbSys', p2='$p2 ,
|| ', isElar='$isElar', isTec='$isTec
$=lcLi=DSN.DB2.LCTL
if \ $tstDist then $@¢
$=ll=$lcLi
$=outCaR = DSN.CADB2.$rzDsn.P0.CDBAMDL
$! else $@¢
$=ll = $tstOut
$=outCaR = $tstOut
$!
if $fun == 'c' then $@¢
$** c=controlSummary QZT00??0 QZT00??1
$= job = QZT00${job67}P
$= lctl = QZT00${p2}0
call jWrite $csDist, "call dsnCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lctl")'"
$;
$>$outLib($lctl)
if $xDocHK then $@¢
$$ %tecSvUnl $dbSys
if $rz = RZ2 then
$$ sub 'dsn.besenwag.$dbSys(qcsBx${p2}p)'
$!
if $rz = RZZ | $dbSys = DBOC | $dbSys=DBOF | $dbSys = DP4G then
$$ %besenWag $dbSys
$;
$= lctl = QZT00${p2}1
call jWrite $csDist, "call dsnCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lctl")'"
$;
$>$outLib($lctl)
$@genConSum
$;
if $xDocHK then $@¢
$= lctl = QZT00${p2}X
$= job = QCSBX${p2}P
$<>
$>$outLib($lctl)
$@% genBesenWagen
call jWrite $csDist, "call dsnCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lctl")'"
$!
$!
if $fun == 'd' then $@¢
$** d=ddlControl QZT09??1
$= job = QZT09${p2}P
$= lctl = QZT09${p2}1
call jWrite $csDist, "call dsnCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lctl")'"
$;
$>$outLib($lctl)
$@genDDLCon
$!
if $fun == 'r' then $@¢
$** r=copyArchive QZT10??0 QZT10??1
$@copyArc0 $>$outLib(QZT10${p2}0)
$;
$@copyArc1 $>$outLib(QZT10${p2}1)
$;
call jWrite $csDist, "call dsnCopy" ,
"'"$outLib"(QZT10"$p2"0)' ,"
call jWrite $csDist, " , '"$rz"/"$ll"(QZT10"$p2"0)'"
call jWrite $csDist, "call dsnCopy" ,
"'"$outLib"(QZT10"$p2"1)' ,"
call jWrite $csDist, " , '"$rz"/"$ll"(QZT10"$p2"1)'"
$!
if $fun == 'x1' then $@¢
$** x=einmalAktion alte copyArc LCTLs archivieren
call jWrite $csDist, "call dsnCopy" ,
"'"$rz"/"$lcLi"(QZT10"$p2"0)' ,"
call jWrite $csDist, " , '"$tstOut"(QZT10"$p2"0)'"
call jWrite $csDist, "call dsnCopy" ,
"'"$rz"/"$lcLi"(QZT10"$p2"1)' ,"
call jWrite $csDist, " , '"$tstOut"(QZT10"$p2"1)'"
call jWrite $csDist, "call dsnCopy" ,
"'"$rz"/"$lcLi"(QMW10000)' ,"
call jWrite $csDist, " , '"$tstOut"(QMW10"$p2"0)'"
call jWrite $csDist, "call dsnCopy" ,
"'"$rz"/"$lcLi"(QMW1000M)' ,"
call jWrite $csDist, " , '"$tstOut"(QMW10"$p2"M)'"
$!
if $fun == 'x' then $@¢
$** x=einmalAktion delete old copyArc LCTLs
dl = DSN.DB2.LCTL
ll = $dbSys'.DBAA.LCTL'
d1 = $dbC
j2 = iirz2c(rz)ii$dbC
call jWrite $csDist, "call dsnDel" $rz", '"dl"("$rz"SQL)'"
call jWrite $csDist, "call dsnDel" $rz", '"dl"("$rz"SQLOL)'"
call jWrite $csDist, "call dsnDel" $rz", '"dl"(RZ2SQL)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMT00"j2"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMT00"j2"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMT002F0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMT002F1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00"j2"M)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00"j2"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00081)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00082)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00101)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00102)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00131)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW00132)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW002Q1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW1000M)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW10000)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW71"j2"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QMW712"d1"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G01)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G02)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G03)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G04)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G05)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G06)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G07)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416G08)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416201)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416202)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416203)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416204)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416205)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416206)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416207)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416208)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416223)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416224)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416225)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416226)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416227)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416228)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416611)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416612)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416613)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416614)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416615)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416616)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416617)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QM416618)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT00"j2"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT00"j2"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT002"d1"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT002"d1"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT10"j2"M)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT10"j2"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT10"j2"1)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT102"d1"0)'"
call jWrite $csDist, "call dsnDel" $rz", '"ll"(QZT102"d1"1)'"
$!
if $fun == 'm' then $@¢
$** m=ca2 dba Models FICD? IIC? EXCL? STOP?
$> $outLib(EXCL#$p2)
$@% genId EXCL$dbSys EXCL#$p2 QGS* exclude cbamdl für tecSv
$$ $' and'
$@% excludeCaMdl T
$<>
$> $outLib(STOP#$p2)
$$ #HCCD STOP,STOP
$@% genId STOP$dbSys STOP#$p2 QGS* stop cdbamdl für tecSv
$$ $' and'
$@% excludeCaMdl T
$;
$> $outLib(FICD#$p2)
$@% tecSvSql f FICD$dbSys FICD#$p2
$@% excludeCaMdl S
if $rz == 'RR2' & $dbSys == 'DBOF' then
$$- ' fetch first 16500 rows only'
else if $rz == 'RQ2' & $dbSys == 'DBOF' then
$$- ' fetch first 10500 rows only'
$;
$> $outLib(IIC#$p2)
$@% tecSvSql i IIC$dbSys IIC#$p2
$@% excludeCaMdl S
$@% mdlDist - $p2, $dbSys
$!
$/gen/
$proc $@/mdlDist/
parse arg , p2, dbSys
call jWrite $csDist, "call dsnCopy '"$outLib"(EXCL#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(EXCL"dbSys")'"
call jWrite $csDist, "call dsnCopy '"$outLib"(STOP#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(STOP"dbSys")'"
call jWrite $csDist, "call dsnCopy '"$outLib"(FICD#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(FICD"dbSys")'"
call jWrite $csDist, "call dsnCopy '"$outLib"(IIC#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(IIC"dbSys")'"
if \ ${?mdlDistRz} then $@¢
$=mdlDistRz = $''
$=csDis2 =. jOpen(file($outLib"(##dbaMRZ)" $outAtt), '>')
call jWrite $csDis2, $"$#:"
call jWrite $csDis2, $"$** wsh script: distribute",
$funInfo "to rz"
call jWrite $csDis2, $"$** generiert" $myTst
call jWrite $csDis2, "rz = RZX"
call jWrite $csDis2, "rzD =- iiRz2Dsn($rz)"
call jWrite $csDis2, $"dst = $rz/dsn.cadb2.$rzD.P?.cdbaMdl"
call jWrite $csDis2, ""
call jWrite $csDis2, $"$#@"
call jWrite $csDis2, $"if $rz = 'RZ0' then $@¢"
call jWrite $csDis2, " call dsnCopy ",
$"'DSN.SOURCE.CADB.CDBAMDL', $dst"
$!
if $mdlDistRz <> $rz then $@¢
$=mdlDistRz = $rz
call jWrite $csDis2, $"$! else if $rz = '"$rz$"' then $@¢"
call jWrite $csDis2, " call dsnCopy ",
$"'DSN.SOURCE.CADB.CDBAMDL', $dst"
$!
call jWrite $csDis2, " call dsnCopy '"$outLib"(EXCL#"p2")' ,"
call jWrite $csDis2, $" , $dst'(EXCL"dbSys")'"
call jWrite $csDis2, " call dsnCopy '"$outLib"(STOP#"p2")' ,"
call jWrite $csDis2, $" , $dst'(STOP"dbSys")'"
call jWrite $csDis2, " call dsnCopy '"$outLib"(FICD#"p2")' ,"
call jWrite $csDis2, $" , $dst'(FICD"dbSys")'"
call jWrite $csDis2, " call dsnCopy '"$outLib"(IIC#"p2")' ,"
call jWrite $csDis2, $" , $dst'(IIC"dbSys")'"
$/mdlDist/
$****************** generate ID: header & select current ... **********
$proc $@=/genIdCur/
$arg aAA
$@% genId $aAA
--************************************************************
-- Identifikation
--************************************************************
set current path oa1p;
select current timestamp "now", current server "currentServer"
from sysibm.sysDummy1
;
$/genIdCur/
$****************** generate ID3: 3 oder 4 id lines *******************
$proc $@=/genId/
$arg aDi aGe aJo aTi
$@ if $aTi <> '' then
-- $aTi
$@ if aJo <> '-' then
-- $aDi für $rz/$dbSys für Job $aJo
$@ else
-- $aDi für $rz/$dbSys
$@ if $aGe = '-' | $aGe = $aDi then
-- generiert um $myTst
$@ else
-- generiert als $aGe um $myTst
-- durch rz4/dsn.source.tecSv(conSumGe) >>> alle Aenderung da <<<
$/genId/
$****************** write rz?Sql from generated LCTLs *****************
$proc $@/rzEnd/ $** macht nichts mehr mehr
if $rzOne == '' then
call err 'rzEnd empty rzOne'
$= rzOne = $''
$/rzEnd/
$****************** generate controlSummary ***************************
$proc $@=/genConSum/
$@% genIdCur $lctl - $job Control Summary
--*********************************************************************
--$'$$'s fehlende Fullcopies Tablespaces, letzte 8 Tage $xDocNoTx
--*********************************************************************
$@missFullCopies1
and
$@%¢exclude PT * $!
$@%¢missFullCopies2 8$!
commit;
--*********************************************************************
--$'$$'r fehlende RecoveryBases Tablespaces, letzte 8 Tage $xDocNoTx
--*********************************************************************
$@% missBaseV2Beg older8d 8
and
$@% exclude = -vr C
$@% missBaseV2End
commit;
--*********************************************************************
--$'$$'r fehlende Fullcopies Indexspaces, letzte 8 Tage:
--************************************************************
SELECT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,SUBSTR(IX.DBNAME,1,8) AS DBNAME
,SUBSTR(IX.INDEXSPACE,1,8) AS IXSPACE
,IP.PARTITION
,DATE(IX.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
AND IX.COPY = 'Y'
AND IP.SPACE <> -1 -- defineNo is in space not spaceF|
and
$@%¢exclude IX * $!
AND NOT EXISTS (
$@%¢selFullCopy IX.DBNAME IX.INDEXSPACE IP.PARTITION 8$!
)
ORDER BY CREATOR, IXNAME, IP.PARTITION
WITH UR;
commit;
--************************************************************
--$'$$'s Imagecopy Datasets die nicht katalogisiert sind:
--************************************************************
WITH DS AS
(
SELECT DBNAME, TSNAME, DSNUM
,MAX(ICDATE) ICDATE
,MAX(JOBNAME)JOBNAME
,DSNAME
FROM SYSIBM.SYSCOPY C
WHERE ICTYPE IN ('F','I')
AND C.TIMESTAMP >= CURRENT TIMESTAMP - 21 DAYS
and
$@%¢exclude C K$!
GROUP BY DBNAME, TSNAME, DSNUM, DSNAME
)
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(TSNAME,1,8) AS TSNAME
,CHAR(DSNUM) AS PART
,ICDATE, JOBNAME, DSNAME
FROM DS
where S100447.DSLOCATE(DSNAME) IS NULL
ORDER BY DBNAME, TSNAME, PART
WITH UR;
commit;
$@ if $beSave then $@=/conSuXBS/
--************************************************************
--$'$$'r XBS TS: fehlende RecoveryBases letzte 2 Tage:
--************************************************************
$@% missBaseV2Beg older2d 2
and
$@%¢setQDbTs = -vr $!
$@bePred
$@% missBaseV2End
commit;
$/conSuXBS/
$@ if $xDocHK then $@=/conSumXDoc/
--*********************************************************************
--- $xDocTx ***
$@ if $isElar then $@=¢
--- elar NDBS: neuer Elar Design seit 2013/14 ***
$! $@ else $@=¢
--- XC/XR Kontrolle AuditPendenz 2015 ***
$!
$@xDocUnlErr
$@xDocRecErr
$@ if $isElar & $xDocHK then $@=¢ $** ???? war xDocUnl
--********************************************************************
--$'$$'r XB ndbs - nicht katalogisierte Unloads
--********************************************************************
with s as
(
select db, ts, pa, stage || ' ' || staTb stage, unl
from oa1p.tqz005TecSvUnload
where unl <> '' and stage <> '-r'
)
select *
from s
where s100447.dslocate(unl) is null
order by db, ts, pa
fetch first 1000 rows only
;
$!
$/conSumXDoc/
$/genConSum/
$****************** generate DDLControl *******************************
$proc $@/genDDLCon/
$@% genIdCur $lctl - $job Control DDL
if $isElar then $@=/ddlElar/
--************************************************************
--$'$$' XB tablepaces mit > 200 Partitionen:
--************************************************************
select dbname, name, partitions
from sysibm.systablespace
where (partitions > 254 and dbName not like 'XB%')
or ( partitions > 200 and dbname like 'XB%'
$@¢ if $dbSys = 'DVBP' then $@#¢
and not ( -- Liste der 65 alten / temporären / fehlerhaften TS
-- mit > 200 Partitionen die wir nicht anzeigen
-- gemaess Absprache mit Elar vom 17.7.14
(dbName = 'XBCZ1001' and name in ('SHS0101$', 'SIT02001'
, 'SIT0201$', 'SPS0101$', 'SPS0301$'))
or (dbName = 'XBDJC001' and name in ('SDJC0041', 'SDJC0042'
, 'SDJC0043', 'SDJC004H', 'SDJC0051', 'SDJC0052', 'SDJC0053'
, 'SDJC005H', 'SDJC0061', 'SDJC0062', 'SDJC0063', 'SDJC006H'
, 'SDJC0071', 'SDJC0072', 'SDJC0073', 'SDJC007H', 'SDJC0081'
, 'SDJC0082', 'SDJC0083', 'SDJC008H'))
or (dbName = 'XBDJC002' and name in ('SDJC0101', 'SDJC0102'
, 'SDJC0103', 'SDJC010H', 'SDJC0111', 'SDJC0112', 'SDJC0113'
, 'SDJC011H'))
or (dbName = 'XBDPM001' and name in ('SDPM0021', 'SDPM0022'
, 'SDPM0023', 'SDPM002H'))
or (dbName = 'XBDPM002' and name in ('SDPM0181', 'SDPM0182'
, 'SDPM0183', 'SDPM018H', 'SDPM0221', 'SDPM0222', 'SDPM0223'
, 'SDPM022H'))
or (dbName = 'XBFC4001' and name in ('SFC40021', 'SFC40022'
, 'SFC40023', 'SFC4002H', 'SFC40031', 'SFC40032', 'SFC40033'
, 'SFC4003H', 'SFC40041', 'SFC40042', 'SFC40043', 'SFC4004H'
, 'SFC40051', 'SFC40052', 'SFC40053', 'SFC4005H', 'SFC40061'
, 'SFC40062', 'SFC40063', 'SFC4006H', 'SFC40071', 'SFC40072'
, 'SFC40073', 'SFC4007H'))
or (dbName = 'XBFQY002' and name in ('SFQY0021', 'SFQY0022'
, 'SFQY0023', 'SFQY0024', 'SFQY002H'))
or (dbName = 'XBFC4002' and name in ('SFC40091', 'SFC40092'
, 'SFC40093', 'SFC4009H'))
)
$! $!
)
order by dbName, name
;
commit;
$/ddlElar/
$@=/ddlCon1/
--************************************************************
--$'$$' LOB-Tablespaces mit falschen Spezifikationen:
--************************************************************
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(NAME,1,8) AS TSNAME
,BPOOL
,LOG
FROM SYSIBM.SYSTABLESPACE S
WHERE TYPE = 'O'
AND (BPOOL NOT IN('BP8','BP32K') OR LOG = 'N')
and
$@%¢exclude S L$!
ORDER BY DBNAME, TSNAME
WITH UR
;
commit;
--************************************************************
--$'$$' Tablespaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(TS.DBNAME,1,8) AS DBNAME
,SUBSTR(TS.NAME,1,8) AS TSNAME
,TS.BPOOL
,SUBSTR(PT.STORNAME,1,8) AS STORNAME
,PT.STORTYPE
FROM SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE ts.dbNAME = PT.DBNAME
AND TS.NAME = PT.TSNAME
and
$@%¢exclude PT F$!
AND (TS.BPOOL = 'BP0'
OR ( PT.STORNAME <> 'GSMS'
and (pt.dbName not like 'XB%'
or pt.storName not in
('GSMS1', 'GSMS2', 'GSMS3', 'GSMS4') ) )
OR PT.STORTYPE = 'E')
ORDER BY DBNAME, TSNAME
WITH UR;
commit;
--************************************************************
--$'$$' Indexspaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,IX.BPOOL
,SUBSTR(IP.STORNAME,1,8) AS STORNAME
,IP.STORTYPE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
and
$@%¢exclude IX F$!
AND (IX.BPOOL = 'BP0'
OR ( IP.STORNAME <> 'GSMS'
and (ix.dbName not like 'XB%'
or ip.storName not in
('GSMS1', 'GSMS2', 'GSMS3', 'GSMS4') ) )
OR IP.STORTYPE = 'E')
ORDER BY CREATOR, IXNAME
WITH UR;
commit;
--************************************************************
--$'$$' tableParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(PT.DBNAME,1,8) "db"
,SUBSTR(PT.TSNAME,1,8) "ts"
,PT.PARTITION "part"
,pt.pQty "priQty"
,pt.sQty "secQty"
,r.extents
FROM
SYSIBM.SYSTableSpace ts
join SYSIBM.SYSTABLEPART pt
on pt.dbName = ts.dbName and pt.tsname = ts.name
left join sysibm.sysTableSpaceStats r
on pt.dbNAME = r.DBNAME
AND pt.tsName = r.NAME
AND ts.dbid = r.dbid
AND ts.psid = r.psid
AND pt.partition = r.partition
WHERE (pt.pQty <> -1 or pt.sQty <> -1 or r.extents > 500)
and
$@%¢exclude PT L$!
ORDER BY pt.DBNAME, pt.tsNAME, PT.PARTITION
fetch first 1000 rows only
WITH UR;
commit;
--************************************************************
--$'$$' IndexParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(Ip.ixCREATOR,1,8) AS CREATOR
,SUBSTR(Ip.ixNAME,1,16) AS IXNAME
,IP.PARTITION
,ip.pQty "priQty"
,ip.sQty "secQty"
,ip.extents
FROM
SYSIBM.SYSINDEXES Ix
join SYSIBM.SYSINDEXPART IP
on ix.creator = ip.ixCreator and ix.name = ip.ixName
left join SYSIBM.SYSINDEXSpaceStats r
on ix.creator = r.creator and ix.name = r.creator
and ix.dbid = r.dbid and ix.isobid = r.isobid
and ip.partition = r.partition
WHERE (ip.pQty <> -1 or ip.sQty <> -1 or r.extents > 300)
and
$@%¢exclude IX L$!
order by ix.creator, ix.name, ip.partition
fetch first 1000 rows only
WITH UR;
$/ddlCon1/
$/genDDLCon/
$****************** generate Excludes *********************************
$proc $@/exclude/
$*( exF K nicht Katalogisierte image Copy
L falsche spezifikation LOB usw
F Falsche spezifikation andere
S TecSv SQL nur fuer IIC und FICD#* und IIC#*
T TecSv SQL andere
C Controlsummary
* alle anderen
$*)
parse upper arg , q exF
$@%¢setQDbTs - q$!
$=exF=- exF
$@=¢
----- begin @proc exclude: excludes --- $exF --------------------------
NOT ($db LIKE 'WKDB%') -- DB2 WORK DATABASE
AND NOT ($db LIKE '%MAREC%') -- marec generated
AND NOT ($db LIKE 'QZ91%') -- test klem 43
AND NOT ($db LIKE 'QZ92%') -- test klem 43
and not translate($db, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT ($db LIKE 'DB2ALA%') -- marec generated
AND NOT ($db LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT ($db LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT ($db LIKE 'DB2PLAN%' -- explain tables
$@¢ if q <> 'IX' then $@=¢
and translate(left($ts, 7), '999999999AA', '012345678FG')
= 'A999999' -- user explain tables
$! else $@=¢
-- cannot exclude user explain tables ONLY for indexes
$! $!
)
$!
if pos($exF, 'FL') > 0 | $isTec then $@=¢
AND NOT ($db like 'DSN%')
$! else $@=¢
AND NOT ($db like 'DSNDB%') -- DB2 CATALOG
AND NOT ($db LIKE 'DSN8%') -- IBM TEST DB
AND NOT ($db = 'DSNTESQ') -- DB2 CATALOG CLONE
$!
if pos($exF, '*CSTK') > 0 & $q <> 'IX' then $@=¢
AND NOT ($db like 'CSQ%' AND $ts like 'TSBLOB%' )
-- M-QUEUE DATENBANK
$!
if pos($exF, 'FL') > 0 then $@=¢
AND NOT ($db = 'SYSIBMTA') -- engineering
AND NOT ($db = 'SYSIBMTS') -- engineering
AND NOT ($db like 'IDTA%') -- ibm tools
AND NOT ($db = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT ($db = 'DB2OSC') -- osc
AND NOT ($db like 'DSQ%') -- qmf databse
AND $db NOT IN ('DUTILTST','XSN8D71L','DB2XML')
$!
if wordPos($dbSys, 'DBTF') > 0 then $@=¢
AND NOT ($db LIKE 'DAU%') -- Schulung Gerrit
$!
if wordPos($dbSys, 'DX0G') > 0 then $@=¢
AND NOT ($db LIKE '%1P%') -- PROTOTYPEN
AND NOT ($db LIKE 'DXB%') -- PROTOTYPEN
AND NOT ($db LIKE 'DGDB%') -- PROTOTYPEN
$!
if $exF == 'L' then $@=¢
AND $db NOT LIKE 'PTDB%'
$@ if q <> 'IX' then $@=¢
AND NOT ($db = 'DXB03'
AND $ts in ('LXBH111','LXBH111X')) $!
$@ if $isTec then $@=¢
AND $db NOT LIKE 'BMC%'
AND $db NOT LIKE 'DCMN00%' --Hat cloneTable Alter aufwendig
$!
$! else $@/excludeNotL/
if $isTec & $q <> 'IX' & pos($exF, '*CKST') > 0 then $@=¢
AND NOT ($db = 'OS80A1P' AND $ts = 'A810A'
$@ if $exF == 'S' then
$** Achtung -- Komentar gibt DBA Fehler
and basTst > current timestamp - 108 hours /* 4.5 tage */
$@ else if $exF == 'C' then
$** Achtung -- Komentar gibt DBA Fehler
and basTst > current timestamp - 84 hours /* 3.5 tage */
) -- IMT1201P macht Load mit ImageCopy
-- aber nachher monatelang nichts mehr
-- ZeitKonflikt mit tecSv |
$!
if $dbSys = 'DP4G' then $@¢
if $exF == 'F' then
if $q == IX then $@=¢
AND NOT $db = 'DB2PMPDB' -- PMON KITP2
$! else $@=¢
AND NOT ($db = 'DB2PMPDB'
AND $ts like 'ACCS%') -- PMON KITD2
$!
$@=¢
AND NOT $db in ('DB2PDB', 'DB2PDB2', 'DB2PDB3') -- performance DB
$@ if $exF == 'F' then $@=¢
$@ if q \== 'IX' then
AND NOT ($db = 'AC04A1P' AND $ts = 'SAC041A' ) -- ACF Gründler
AND NOT ($db = 'AC05A1P' ) -- ACF Gründler
$!
$!
$!
if $dbSys = 'DBOC' then $@=¢
AND NOT ($db = 'DB2PDB') -- performance DB
AND NOT ($db = 'DB2XML') -- performance DB
$!
$** if $isElar & $exF <> 'K' then
if $xDocNS & $q <> 'IX' & pos($exF, '*CST') > 0 then $@=¢
and not
$@% xDocPred $db $ts
$!
if pos($exF, 'ST') > 0 & $beSave then $@=¢
and not
$@bePred
$!
$/excludeNotL/
$@=¢
----- end @proc exclude: excludes --- $exF --------------------------
$!
$/exclude/
$proc $@/excludeCaMdl/
$arg exF
$@% exclude = -S $exF
$| $for li $$- repAll(strip($li, 't'), '%', '%%')
$/excludeCaMdl/
$****************** set vars q, db and ts ******************************
$proc $@/setQDbTs/
parse arg , q
hasQual = \ abbrev(q, '-')
q = strip(translate(q, ' ', '-'))
$= q =- q
quD = copies(q'.', hasQual)
upper q
$=db =- quD'dbName'
if q == 'S' then $@¢
$= ts =- quD'name'
$! else if q == 'IX' then $@¢
$= ts = ???noTs???
$! else if q == 'VR' then $@¢
$= db =- quD'db'
$= ts =- quD'ts'
$! else $@=¢
$= ts =- quD'tsName'
$!
$/setQDbTs/
$****************** BE save *******************************************
$proc $@=/bePred/
($db = 'BE01A1P' and $ts like 'A0%' -- beSave QC515* alle 2h
or $db = 'CD02A1P' and $ts = 'A600A')
$/bePred/
$****************** missing fullcopies alt ****************************
$proc $@=/missFullCopies1/
---- begin @proc missFullCopies1: fehlende Fullcopies -----------------
SELECT SUBSTR(PT.DBNAME,1,8) AS DBNAME
,SUBSTR(PT.TSNAME,1,8) AS TSNAME
,PT.PARTITION
,DATE(TS.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE ts.dbNAME = pt.DBNAME
AND TS.NAME = PT.TSNAME
---- end @proc missFullCopies1: fehlende Fullcopies -----------------
$/missFullCopies1/
$proc $@/missFullCopies2/
parse arg , days
$@=¢
---- begin @proc missFullCopies2: fehlende Fullcopies -----------------
AND TS.NTABLES <> 0
AND PT.SPACE <> -1 -- define no is only in space not spaceF |
AND NOT EXISTS (
$@%¢selFullCopy - PT.DBNAME PT.TSNAME PT.PARTITION arg(2)$!
)
ORDER BY DBNAME, TSNAME, PT.PARTITION
WITH UR;
---- end @proc missFullCopies2: fehlende Fullcopies -----------------
$!
$/missFullCopies2/
$proc $@/selFullCopy/
parse arg , db ts part days
$@=¢
---- begin @proc selFUllCopy: select fullcopy etc. --------------------
SELECT ' '
FROM SYSIBM.SYSCOPY CP
WHERE $-¢db$! = CP.DBNAME
AND $-¢ts$! = CP.TSNAME
AND cp.dsNum in ($-¢part$!, 0)
-- fullcopy or fullLog
AND (( CP.ICTYPE IN ('F','R','X') -- fullcopy or fullLog
AND CP.TIMESTAMP > CURRENT TIMESTAMP - $-¢days$! DAYS
) or ((CP.ICTYPE = 'C' -- created today
-- part added today
or (CP.ICTYPE = 'A' and CP.sType = 'A')
) and date(cp.timestamp) >= current date
) )
---- end @proc selFUllCopy: select fullcopy etc. --------------------
$!
$/selFullCopy/
$proc $@=/genBesenWagen/
$@% genIdCur $lctl - $job BesenWagen $xDocTx
$@xDocUnlErr
$@xDocRecErr
$@ if \ $isElar then $@=¢
--*********************************************************************
-- $xDocTx: fehlende Fullcopies/Recoverybases, letzte 8 Tage
--*********************************************************************
select char(db, 8) db, char(ts, 8) ts, pa
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(recSta, 1, 40) recoveryState
, substr(case when basTy <> ' '
then basTy || ' ' || char(basTst) else '' end, 1, 21)
"last fullCopy"
, substr(case when unl <> '' then char(unlTst) else '' end
, 1, 10) "unload"
-- , z.*
$@xDocFromRecovLoad
and ( fun not in ('r', 'l', '-')
or (stage = 'UL' and lok <> 'l'
and staUpd < current timestamp - 1 day ) )
order by db, ts, pa
$@stageInfo
;
$!
--*********************************************************************
--FixBesenwagen fuer $xDocTx
--*********************************************************************
select char(db, 8) db, char(ts, 8) ts, pa
, substr(fqzFmtBin7(spc), 1, 7) spaceBy
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(recSta, 1, 40) recoveryState
, substr( basTy || char(basTst), 1, 20) "baseTst"
$@xDocFromRecovLoad
and ( fun not in ('r', 'l', '-')
and (recover not in ('ok', 'older8d')
or basTst < (current timestamp - 12 days) + 10 hour)
)
order by bastst, db, ts, pa
;
$/genBesenWagen/
$****************** missing Recover Base Version sept 15 **************
$proc $@=/missBaseV2Beg/
$arg txtLim dayLim
SELECT SUBSTR(db, 1, 8) "db"
, SUBSTR(ts,1,8) "ts"
, pa as "part"
, substr(insTxt, 1, 6) "inst"
, case when recover in ('ok', 'older8d')
then '$txtLim' else recover end recover
, basTyTx
, basPa
, basTst
from $vCr.vQz005RecovDelta
WHERE ( not (recover in ('defNo', 'noTb')
or (recover in ('ok', 'older8d')
and basTst >= current timestamp - $dayLim days )))
$*( WHERE ( recover not in ('ok', 'defNo', 'noTb')
or ( recover = 'ok' and basTst
< current timestamp - $dayLim days )
) $*)
$/missBaseV2Beg/
$proc $@=/missBaseV2End/
order by 1, 2, 3
with ur
;
$/missBaseV2End/
$*(**************** predicate to select ts under xDoc housekeeping ****
is also used with a not in front| ************* $*)
$proc $@/xDocPred/
$arg qDb qTs
if $isElar then $@=¢
($qDb like 'XB%') -- ELAR Dokumente
$! else $@=¢
( ($qDb = 'XC01A1P' and $qTs <> 'A500A'
and ($qTs LIKE 'A2%'or $qTs LIKE 'A5%'))
-- EOS: Armin Breyer
or ($qDb = 'XR01A1P' AND $qTs LIKE 'A2%' )
) -- ERET: Armin Breyer
$!
$/xDocPred/
$*(**************** reovery error of xdoc
summary and details *************************** $*)
$proc $@=/xDocRecErr/
--*********************************************************************
-- $xDocTx: Summary Stages / Recoverybases / Unloads
--*********************************************************************
select substr(fqzFmtBin7(sum(spc))
|| right(' ' || count(*), 8), 1, 15)
"spaceBy count"
, stage
, substr(recSta, 1, 70) recoveryState
$@xDocFromRecovLoad
group by stage, recSta
order by 2, 3
--
-- columns
$@ if \ $isElar then $@=¢
-- stage: ' ' non document tables in XC/XR DBs
$! $@ else $@=¢
-- stage: '-m' missing in stage tables
-- '-a' registered only in txba201
-- '-w' www tables
$!
-- recoveryState:
-- substr(1, 1) recover by
-- 'r' db2 recovery from imageCopy and db2Log
-- 'l' load unload dsn
-- '?' either is not possible or unreliable
-- substr(3...) recover state / warning / error
;
--*********************************************************************
--$xDocConSum $xDocTx: fehlende Recoverybases / Unloads $xDocConSu2
--*********************************************************************
select char(db, 8) db, char(ts, 8) ts, pa
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(recSta, 1, 40) err
, substr(case when basTy <> ' '
then basTy || ' ' || char(basTst) else '' end, 1, 21)
"last fullCopy"
, substr(case when unl <> '' then char(unlTst) else '' end
, 1, 10) "unload"
-- , z.*
$@xDocFromRecovLoad
and ( fun not in ('r', 'l', '-')
$@ if $isElar then $@=¢
or ( stage in ('-w', 'DL', 'UL') and lok <> 'l' )
$! $@ else $@=¢
or ( stage in ('UL') and lok <> 'l'
and staUpd < current timestamp - 1 day )
$!
)
order by db, ts, pa
fetch first 1000 rows only
$@stageInfo
;
$/xDocRecErr/
$****************** unload errors Summary and Details *****************
$proc $@=/xDocUnlErr/
--************************************************************
-- $xDocTx: Statistik Stage tables
--************************************************************
$@xDocUnlErrWith
select stage "stage"
, count(*) "#parts"
, smallInt(count(distinct db || '.' || ts)) "#ts"
, substr(err, 1, 75) "error / info"
from uE
group by stage, err
order by case when stage = '-r' then 0 else 1 end, stage, err
;
--************************************************************
--$xDocConSum $xDocTx: Fehler in stageTables $xDocConSu2
--************************************************************
$@xDocUnlErrWith
select db, ts
, substr(right(' ' || pa, 5), 1, 5) part
, stage || ' ' || staTb
, substr(err, 1, 36) err
, substr(unl, 1, 41) unl
from uE
where err <> '' and not (db = '' and pa < -100)
order by case when stage = '-r' then 0 else 1 end, db, ts, pa
fetch first 1000 rows only
$@stageInfo
;
commit;
$/xDocUnlErr/
$*( *************** unload error with *********************************
union of errors from unoad table
and infos/errors about last load of it ******** $*)
$proc $@=/xDocUnlErrWith/
with uE (db, ts, pa, stage, staTb, unl, err) as
(
select db, ts, pa, stage, staTb, unl
, strip(case
$@ if $isElar then $@=¢
when stage not in ('RW', 'CL', 'UL', 'DL'
, '-m', '-a', '-w', '-r') then ' badStage=' || stage
when unl <> '' and stage in ('RW')
then ' unloadInStage=' || stage
$! $@ else $@=¢
when stage not in ('IN', 'RD', 'RU', 'FZ', 'UL', 'MI', '-r')
or (stage = 'RD'
and not (db = 'XC01A1P' and ts like 'A200A%'))
then ' badStage=' || stage
when unl <> '' and stage in ('RU', 'MI')
then ' unloadInStage=' || stage
$!
else ''
end || ' ' || err) ee
from oa1p.tqz005tecsvUnload u
where db <> ''
union all select db, ts,-101, stage, staTb, unl
, 'refresh from ' || left(char(unlTst), 19)
|| ' to ' || left(char(punTst), 19)
from oa1p.tqz005tecsvUnload u
where db = '' and ts = ''
union all select db, ts,-101, stage, staTb, unl
, 'refresh info ' || info
from oa1p.tqz005tecsvUnload u
where db = '' and ts = ''
union all select db, ts,-101, stage, staTb, unl, err
from oa1p.tqz005tecsvUnload u
where db = '' and ts = '' and err <> ''
union all select db, ts, pa, stage, staTb
, char(unlTst), 'refresh older 3h'
from oa1p.tqz005tecsvUnload
where db='' and ts='' and pa=-99
and unlTst < current timestamp - 3 hours
union all select '', '', -99, '-r', '', '', count(*) ||' refresh rows'
from oa1p.tqz005tecsvUnload
where db='' and ts='' and pa=-99 and stage = '-r'
having count(*) <> 1
)
$/xDocUnlErrWith/
$****************** from recov/Load view with recSta ******************
$proc $@=/xDocFromRecovLoad/
from ( select r0.*
, fun || case when recLR in ('r', '2')
then ' ' || recover else '' end
|| case when recLR in ('l', '2')
then rTrim(' ' || load) else '' end recSta
$@ if $useLgRn then $@=¢
from $vCr.vQz005RecovDeltaLoadLgRn r0) r
$! $@ else $@=¢
from $vCr.vQz005RecovDeltaLoad r0) r
$!
where
$@% xDocPred db ts
$/xDocFromRecovLoad/
$****************** comment on stageInfo fields ***********************
$proc $@=/stageInfo/
-- stage: substr(1,2) = stage
-- substr(4,2) = stageTables
$@ if $isElar then $@=¢
-- i = BUA.TXBI003 segment table
-- a = bua.txba201
-- c = BUA.TXBC021 unload table
-- s = BUA.TXBC021s unload table
$! $@ else $@=¢
-- 1 = OA1P.TXC106A1 EOS alt ==> OA1P??.TXC200A1
-- 4 = OA1P.TXC406A1 eRet AFP ==> OA1P.TXC501A1+502A1
-- EOS PDF ==> OA1P.TXC51*A1
-- r = OA1P.TXR106A1 eRet ==> OA1P.TXR200A1+201A1
$!
$/stageInfo/
$****************** tecSave sql ***************************************
$proc $@=/tecSvSql/
$arg tsF aAA
$@ if $tsF == 'i' then $@=¢
#HCCD (TS) RTS incremental IMAGE COPY
$@% genId $aAA QGS300${dbC}P tecSv incremental copy
$! $@ else if $tsF == 'f' then $@=¢
#HCCD (TS) RTS full IMAGE COPY
$@% genId $aAA QGS400${dbC}P tecSv full copy
$! $@ else $@¢
call err 'bad fun tsF' $tsF 'in tecSvSql'
$!
SELECT 'DI,PI,PA,IN' , DBID , PSID , PA , INST
/* tecsvCop sql: what copy is needed? full, incremental or none
18.12.15 walter: part=0 wieder eingebaut, inc raus
ignore icType T (term util) and J (compr Dict)
*/
from
( -- r: why and how to copy, join sysTableSpaceStats
select q.*
, overlay(case
when inst is null
then raise_Error(70001, 'inst null '
|| q.dbName || '.' || q.name)
when nTables < 1 then 'n noTables ' || nTables
-- let utility figure out define no or yes
-- but dbAnalyzer always produces RTS not found messages
-- ==> unfortunately not a good idea |
when pSpace = -1 then 'n defineNo ' || pSpace
when basTy <> 'F' then 'f basIcType ' || basTy
when basPa <> pa then 'f multiPart'
when basTst < current timestamp-7 days then 'f week'
when r.updateStatsTime is null then 'f noRts'
when r.copyLastTime is null then 'f r.copyLast null'
when r.nactive * 0.1 <= r.copyupdatedpages
then 'f updates'
/* when incTst < r.copyLastTime - 60 seconds
then 'f i << r.copyLast'
when incTy not in ('I','F') then 'i incIcType ' || incTy */
when r.copyupdatedpages <> 0 then 'i updates'
when r.copyChanges <> 0 then 'i changes'
when r.copyUpdateLRSN is not null then 'i updLRSN'
when r.copyUpdateTime is not null then 'i updTime'
else 'n noUpdates'
end, left(' ' || insTxt, 6), 2, 0, octets) what
from
( -- q decode bas and inc fields
select p.*
, timestamp(substr(bas, 1, 26)) basTst
, substr(bas, 27, 1) basTy
, smallint(substr(bas, 28)) basPa
/* , timestamp(substr(inc, 1, 26)) incTst
, substr(inc, 27, 1) incTy
, smallint(substr(inc, 28)) incPa */
from
( -- p tablespace, instance, tablePart
select s.*
, p.partition pa
, p.space pSpace
, max(value(s.bas0, ''), value(
( select char(timestamp) || icType || dsNum
from sysibm.sysCopy c
where s.dbName = c.dbName and s.name = c.tsName
and p.partition = c.dsNum and p.partition > 0
and s.inst = c.instance
and c.icType not
IN ('A', 'B', 'C', 'D', 'I', 'J', 'M', 'Q', 'T')
order by c.timestamp desc
fetch first 1 rows only
) , ''), '1111-11-11-11.11.11.111111-0' ) bas
/* , max(value(s.inc0, ''), value(
( select char(timestamp) || icType || dsNum
from sysibm.sysCopy c
where s.dbName = c.dbName and s.name = c.tsName
and p.partition = c.dsNum and p.partition > 0
and s.inst = c.instance
and c.icType not
IN ('A', 'B', 'C', 'D', 'J', 'M', 'Q', 'T')
order by c.timestamp desc
fetch first 1 rows only
) , ''), '1111-11-11-11.11.11.111111-0' ) inc */
from
( -- s tablespace and instance
select dbName, name, partitions parts
, dbId, psId, nTables
, i.inst
, case when s.clone <> 'Y' then ' '
when s.instance = i.inst then 'base '
else 'clone' end insTxt
, ( select char(timestamp) || icType || dsNum
from sysibm.sysCopy c
where s.dbName = c.dbName and s.Name = c.tsName
and 0 = c.dsNum and i.inst = c.instance
and c.icType not
IN ('A', 'B', 'C', 'D', 'I', 'J', 'M', 'Q', 'T')
order by c.timestamp desc
fetch first 1 rows only
) bas0
/* , ( select char(timestamp) || icType || dsNum
from sysibm.sysCopy c
where s.dbName = c.dbName and s.Name = c.tsName
and 0 = c.dsNum and i.inst = c.instance
and c.icType not
IN ('A', 'B', 'C', 'D', 'J', 'M', 'Q', 'T')
order by c.timestamp desc
fetch first 1 rows only
) inc0 */
from sysibm.sysTablespace s
left join -- clone handling: add instances
( select 1 from sysibm.sysDummy1
union all select 2 from sysibm.sysDummy1
) i (inst)
on s.instance = i.inst or s.clone = 'Y'
) s
join sysibm.sysTablePart p
on s.dbName = p.dbName and s.name = p.tsName
) p
) q
left join sysibm.sysTableSpaceStats r
on q.dbName = r.dbName and q.name = r.name
and q.dbid = r.dbid and q.psid = r.psid
and q.pa = r.partition and q.inst = r.instance
) r
where what like '$tsF%%' -- doppelte Prozent fuer ca dbAnalyser
and
$/tecSvSql/
$proc $@=/copyArc0/
$** currently always empty
$/copyArc0/
$proc $@=/copyArc1/
$= cre =- if($dbSys == 'DBTF', 'OA1T', 'OA1P')
SELECT CURRENT TIMESTAMP - 3 MINUTES,
CHAR(' SUB#ADB1 $cre.TADM62A1 ', 50)
FROM SYSIBM.SYSDUMMY1
;
SELECT C.DBNAME, C.TSNAME, C.DSNUM, C.TIMESTAMP, C.ICTYPE, C.DSNAME,
CHAR(C.COPYPAGESF * 1024 * S.PGSIZE) COPIED
FROM SYSIBM.SYSCOPY C, SYSIBM.SYSTABLESPACE S
WHERE C.ICTYPE IN ('F', 'I')
AND S.DBNAME = C.DBNAME
AND S.NAME = C.TSNAME
$@¢ if wordPos($dbSys, 'DX0G DVTB') > 0 then $@=¢
AND S.DBNAME = ' no no'
$! $!
ORDER BY 1, 2, 3, 4 DESC
WITH UR
;
$/copyArc1/
$#out 20161005 16:53:50
$#out 20161005 16:53:12
$#out 20161005 16:52:29
fatal error in WSH: bad fun c
in wsh phase run
$#out 20161005 16:50:54
$#out 20161005 16:48:51
$#out 20161005 16:45:32
$#out 20161005 16:34:23
$#out 20161005 16:33:59
fatal error in WSH: bad fun c
in wsh phase run
$#out 20160928 15:36:46
$#out 20160928 15:33:31
$#out 20160928 15:31:36
$#out 20160928 15:27:21
$#out 20160928 15:21:42
$#out 20160927 14:28:25
}¢--- A540769.WK.REXX(CONSUMGF) cre=2012-06-20 mod=2015-09-23-09.25.10 A540769 ---
$#@
$*( control summary generator Version 2.8 23. 9.15
Achtung: braucht wsh5
4. 5.15 log Discontinuity Delta (timing window ingorieren)
9. 3.15 besenwagen fuer alle DBOF
19.12.14 save nonUser explain tables
3.12.14 fix fetch first only rr2/rq2/dbof, m rz dependent, RQ2 BE
27.11.14 fix define no: aus space statt (falsch) spaceF auslesen
11. 9.14 rz1 raus, rq2 rein, rz?sql raus
18. 8.14 conSum Elar: Fehler in txbc021/s rapportiern ohne absturz
8. 8.14 copyArc: alles neu erstellen, nicht mehr reNamen
18. 7.14 dvbp: 65 TS mit > 200 Partitionen ausschliessen
$*)
$=fun = c $** c=controlSummary QZT00??0 QZT00??1
$** d=ddlControl QMW71??1
$** r=copyArchive QZT10??0 QZT10??1
$** m=ca2 dba Models FICD? IIC? EXCL? STOP?
$** x=einmalAktion
$=usePlex = 1 $** 1=new plex naming convention, 0=old Rz naming
$=usePlex =- $fun = 'c' $** zurzeit noch nicht weiter ausgebreitet
$=tstOut= - $** - out to productive libs, otherwise to this lib
$=tstOut=- userid()'.tst.tecSv'
$=logDisDelta = 15 minutes
$=useLgRn = 0
$****************** generate all LCTLs for all rz/dbSys ****************
if $tstOut == '-' then $@¢
$= outLib = DSN.SOURCE.TECSV.GEN$-¢copies(PLEX, $usePlex)$!
$= outAtt = ::f mgmtClas(COM#A069)
$! else $@¢
$= outLib = $tstOut
$= outAtt = ::f
$!
if $fun == 'c' then $@¢
$= distMbr = ##conSum control Summary und TecSv LCTLs
$! else if $fun == 'd' then $@¢
$= distMbr = ##ddlCon ddl Control LCTLs
$! else if $fun == 'm' then $@¢
if $tstOut == '-' then
$= outLib = DSN.SOURCE.CADB.CDBAMGEN
$= distMbr = ##dbaMdl ca DBA Models
$! else if $fun == 'r' then $@¢
$= distMbr = ##copyAr copyArchive LCTLs
$! else if $fun == 'x' then $@¢
$= distMbr = ##xxDist einmalAktion
$! else $@¢
call err 'bad fun' $fun
$!
$= funInfo =- subWord($distMbr, 2)
$= distMbr =- word($distMbr, 1)
$=csDist =. jOpen(file($-outLib"("$-distMbr")" $-outAtt), '>')
call jWrite $csDist, $'$#@'
call jWrite $csDist, $'$** wsh script: distribute' $funInfo
$=rzOne= $''
if 0 then $@¢
$>. fEdit()
$@%¢gen rz2 dvbp QMW0010$!
$;
call err 'tstEnd'
$!
if 0 then $@¢
$@%¢gen rz1 dbtf QMW0002$!
$@%¢gen rz1 dvtb QMW0006$!
$@%¢gen rz1 dboc QMW0007$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rz2 dbof QMW0008$!
$@%¢gen rz2 dp2g QMW0013$!
$@%¢gen rz2 dvbp QMW0010$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rr2 dbof QMW0008$!
$@%¢gen rr2 dp2g QMW0013$!
$@%¢gen rr2 dvbp QMW0010$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rq2 dbof QMW0008$!
$@%¢gen rq2 dp2g QMW0013$!
$@%¢gen rq2 dvbp QMW0010$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rz4 dbol QMW0009$!
$@%¢gen rz4 dp4g QMW0016$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rzx de0g QMW0026$!
$@%¢gen rzx devg QMW0027$!
$@%¢gen rzx dpxg QMW0028$!
$@%¢gen rzx dx0g QWM0024$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rzy de0g QMW0029$!
$@%¢gen rzy devg QMW0030$!
$@%¢gen rzy dpyg QMW0031$!
$@rzSQL
$!
if 1 then $@¢
$@%¢gen rzz de0g QMW0017$!
$@%¢gen rzz devg QMW0023$!
$@%¢gen rzz dpzg QMW0025$!
$@rzSQL
$!
call jClose $csDist
if $fun == 'm' then $@¢
call jWrite $csDis2, $"$!"
call jClose $csDis2
$!
call adrIsp "view dataset('"$outLib"("$distMbr")')", 4
$****************** generate all LCTLs for one rz/dbSys ****************
$proc $@/gen/
parse upper arg ., rz dbSys job7
$=rz=- rz
$=rzDsn =- iiRz2Dsn(rz)
$=dbSys=- dbSys
$=isElar=- wordPos($dbSys, 'DVBP DVTB DEVG') > 0
$=hasXDoc =- $dbSys = DBOF | $dbSys = DVBP
if \ $hasXDoc then $@¢
$= xDocTx = $''
$= xDocBrTx = $''
$= xDocNoTx = $''
$! else $@¢
if $isElar then
$= xDocTx = XB docs
else
$= xDocTx = XC/XR docs
$= xDocNoTx = (nicht $xDocTx)
$= xDocBrTx = ($xDocTx)
$!
$=isTec =- abbrev($dbSys, 'DP') | ( $dbSys == 'DBOC')
$=p2 =- iirz2p(rz)iiDBSys2C(dbSys)
if $usePlex then $@¢
$=j2 = $p2
$=d2 = $j2
$=job67 =- '0'iiDBSys2C(dbSys)
$! else $@¢
$=j2 =- iirz2c(rz)iiDBSys2C(dbSys)
$=d2 =- iirz2c($rzDsn)iiDBSys2C(dbSys)
$=job67 = $d2
$!
$= qmw00 = QMW00${j2}
$= qmw71 = QMW71${j2}
if word($rzOne, 1) == $rz then
$= rzOne = $rzOne $dbSys
else if $rzOne == '' then do
$= rzOne = $rz $dbSys
call jWrite $csDist, "say 'copying to" $rz "---------------'"
end
else
call err 'rz='rz 'dbSys='dbSys 'but rzOne='$rzOne
say 'gen rz='$rz', dbSys='$dbSys', j7='job7', j2='$j2 'd2='$d2 ,
|| ', isElar='$isElar', isTec='$isTec
if $usePlex then
$=lcLi=DSN.DB2.LCTL
else
$=lcLi=$dbSys.DBAA.LCTL
if $tstOut == '-' then $@¢
$=ll=$lcLi
$=outCaR = DSN.CADB2.$rzDsn.P0.CDBAMDL
$! else $@¢
$=ll = $tstOut
$=outCaR = $tstOut
$!
if $fun == 'c' then $@¢
$** c=controlSummary QZT00??0 QZT00??1
$= gttNdPaDone = 0
if $rz == 'RZ1' then
$= job =- job7'P'
else
$= job = QZT00${job67}P
$= lctl = QZT00${j2}0
$= lcDi = QZT00${d2}0
call jWrite $csDist, "call csmCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lcDi")'"
$;
$>$outLib($lctl)
if $hasXDoc then $@¢
$$ %tecSvUnl $dbSys
if $rz = RZ2 then
$$ sub 'dsn.besenwag.$dbSys(qcsBxBFp)'
$!
if $rz = RZZ | $dbSys = DBOC | $dbSys=DBOF | $dbSys = DP4G then
$$ %besenWag $dbSys
$;
$= lctl = QZT00${j2}1
$= lcDi = QZT00${d2}1
$= rzOne = $rzOne $lctl
call jWrite $csDist, "call csmCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lcDi")'"
$;
$>$outLib($lctl)
$@genConSum
$;
if $dbSys = DBOF | $dbSys = DVBP then $@¢
$= lctl = QZT00${j2}X
$= lcDi = $lctl
$= job = QCSBX${j2}P
$<>
$>$outLib($lctl)
$@% genBesenWagen
$!
$!
if $fun == 'd' then $@¢
$** d=ddlControl QMW71??1
$= gttNdPaDone = 0
$= job = ${qmw71}P
$= lctl = ${qmw71}1
$= lcDi = $lctl
call jWrite $csDist, "call csmCopy '"$outLib"("$lctl")' ,"
call jWrite $csDist, " , '"$rz"/"$ll"("$lctl")'"
$;
$>$outLib($lctl)
$@genDDLCon
$!
if $fun == 'r' then $@¢
$** r=copyArchive QZT10??0 QZT10??1
$@copyArc0 $>$outLib(QZT10${d2}0)
$;
$@copyArc1 $>$outLib(QZT10${d2}1)
$;
call jWrite $csDist, "call csmCopy" ,
"'"$outLib"(QZT10"$d2"0)' ,"
call jWrite $csDist, " , '"$rz"/"$ll"(QZT10"$d2"0)'"
call jWrite $csDist, "call csmCopy" ,
"'"$outLib"(QZT10"$d2"1)' ,"
call jWrite $csDist, " , '"$rz"/"$ll"(QZT10"$d2"1)'"
$!
if $fun == 'x1' then $@¢
$** x=einmalAktion alte copyArc LCTLs archivieren
call jWrite $csDist, "call csmCopy" ,
"'"$rz"/"$lcLi"(QZT10"$d2"0)' ,"
call jWrite $csDist, " , '"$tstOut"(QZT10"$d2"0)'"
call jWrite $csDist, "call csmCopy" ,
"'"$rz"/"$lcLi"(QZT10"$d2"1)' ,"
call jWrite $csDist, " , '"$tstOut"(QZT10"$d2"1)'"
call jWrite $csDist, "call csmCopy" ,
"'"$rz"/"$lcLi"(QMW10000)' ,"
call jWrite $csDist, " , '"$tstOut"(QMW10"$d2"0)'"
call jWrite $csDist, "call csmCopy" ,
"'"$rz"/"$lcLi"(QMW1000M)' ,"
call jWrite $csDist, " , '"$tstOut"(QMW10"$d2"M)'"
$!
if $fun == 'x' then $@¢
$** x=einmalAktion delete old copyArc LCTLs
call jWrite $csDist, "call csmDel" $rz", '"$ll"("$qmw00"0)'"
call jWrite $csDist, "call csmDel" $rz", '"$ll"("$qmw00"M)'"
call jWrite $csDist, "call csmDel" $rz ", '"$ll"(QZT10"$j2"M)'"
$!
if $fun == 'm' then $@¢
$** m=ca2 dba Models FICD? IIC? EXCL? STOP?
$= bb =. jBuf()
$;
$>.bb
$@%¢exclude = -S T$!
$;
ll = $bb'.BUF'
$** doppelte % fuer ca dbAnalyser
do lx=1 to m.ll.0
m.ll.lx = repAll(strip(m.ll.lx, 't'), '%', '%%')
end
$;
$> $outLib(EXCL#$p2)
$@%¢genId3 EXCL$dbSys EXCL#$p2 $!
$$ $' and'
$@<.bb
$;
$> $outLib(STOP#$p2)
$$ #HCCD STOP,STOP
$@%¢genId3 STOP$dbSys STOP#$p2 $!
$$ $' and'
$@<.bb
$;
$> $outLib(FICD#$p2)
$@%¢tecSvSql f FICD$dbSys FICD#$p2 $!
$@<.bb
if $rz == 'RR2' & $dbSys == 'DBOF' then
$$- ' fetch first 16500 rows only'
else if $rz == 'RQ2' & $dbSys == 'DBOF' then
$$- ' fetch first 10500 rows only'
$;
$> $outLib(IIC#$p2)
$@%¢tecSvSql i IIC$dbSys IIC#$p2 $!
$@<.bb
$@% mdlDist - $p2, $dbSys
$!
$/gen/
$proc $@/mdlDist/
parse arg , p2, dbSys
call jWrite $csDist, "call csmCopy '"$outLib"(EXCL#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(EXCL"dbSys")'"
call jWrite $csDist, "call csmCopy '"$outLib"(STOP#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(STOP"dbSys")'"
call jWrite $csDist, "call csmCopy '"$outLib"(FICD#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(FICD"dbSys")'"
call jWrite $csDist, "call csmCopy '"$outLib"(IIC#"p2")' ,"
call jWrite $csDist, " , '"$rz"/"$outCaR"(IIC"dbSys")'"
if \ ${?mdlDistRz} then $@¢
$=mdlDistRz = $''
$=csDis2 =. jOpen(file($outLib"(##dbaMRZ)" $outAtt), '>')
call jWrite $csDis2, $"$#: $** distribute cDbaMdl to rz"
call jWrite $csDis2, "rz = RZX"
call jWrite $csDis2, $"dst = $rz/dsn.cadb2.$rz.P7.cdbaMdl"
call jWrite $csDis2, ""
call jWrite $csDis2, $"$#@"
call jWrite $csDis2, $"if $rz = 'RZ0' then $@¢"
call jWrite $csDis2, " call csmCopy ",
$"'DSN.SOURCE.CADB.CDBAMDL', $dst"
$!
if $mdlDistRz <> $rz then $@¢
$=mdlDistRz = $rz
call jWrite $csDis2, $"$! else if $rz = '"$rz$"' then $@¢"
call jWrite $csDis2, " call csmCopy ",
$"'DSN.SOURCE.CADB.CDBAMDL', $dst"
$!
call jWrite $csDis2, " call csmCopy '"$outLib"(EXCL#"p2")' ,"
call jWrite $csDis2, $" , $dst'(EXCL"dbSys")'"
call jWrite $csDis2, " call csmCopy '"$outLib"(STOP#"p2")' ,"
call jWrite $csDis2, $" , $dst'(STOP"dbSys")'"
call jWrite $csDis2, " call csmCopy '"$outLib"(FICD#"p2")' ,"
call jWrite $csDis2, $" , $dst'(FICD"dbSys")'"
call jWrite $csDis2, " call csmCopy '"$outLib"(IIC#"p2")' ,"
call jWrite $csDis2, $" , $dst'(IIC"dbSys")'"
$/mdlDist/
$****************** generate ID: header & select current ... **********
$proc $@=/genId/
$=aTi=- arg(2)
-- $aTi
-- lctl $lctl: sql für job $job für $rz/$dbSys
$@¢ if $lctl \== $lcDi then
$$ -- name $lcDi in Library in $rz |||
$!
$@%¢genId3 $lctl$!
--************************************************************
-- Identifikation
--************************************************************
set current path oa1p;
select current timestamp "now", current server "currentServer"
from sysibm.sysDummy1
;
$/genId/
$****************** generate ID3: 3 id lines **************************
$proc $@/genId3/
parse arg , mbr diM
if diM \== '' then
diM = ' als' diM
$@=¢
-- $-¢mbr$! für $rz/$dbSys vom $-¢f('%t E um %t t')$!
-- generiert$-¢diM$! durch rz4/dsn.source.tecSv(conSumGe)
-- alle Aenderung dortdrin ||||||
$!
$/genId3/
$****************** write rz?Sql from generated LCTLs *****************
$proc $@/rzSQL/ $*( brauchen wir nicht mehr .............
if $rzOne == '' then
call err 'rzSQL empty rzOne'
rz = word($rzOne, 1)
if $fun == 'c' then $@¢
say 'rzSQL:' $rzOne '==>' $outLib'('rz'SQL)'
$;
$>- $outLib'('rz'SQL)'
$do wx=2 by 2 to words($rzOne) $@¢
$$- '¢'word($rzOne, wx)'!'
$@<--¢$outLib'('word($rzOne, $wx+1)')'$!
$!
$;
call jWrite $csDist, "call csmCopy '"$outLib"("rz"SQL)' ,"
if $tstOut == '-' then
call jWrite $csDist, " , '"$rz"/DSN.DB2.LCTL("$rzDsn"SQL)'"
else
call jWrite $csDist, " , '"$rz"/"$outLib"("$rzDsn"SQL)'"
$! $*)
$= rzOne = $''
$/rzSQL/
$****************** generate controlSummary ***************************
$proc $@=/genConSum/
$@%¢genId Control Summary$!
--*********************************************************************
$@ if \ $isElar then $@=¢
--$'$$'s fehlende Fullcopies Tablespaces, letzte 8 Tage:
$! $@ else $@=¢
--$'$$'s DXB - fehlende Fullcopies TS, letzte 8 Tage:
$!
--*********************************************************************
$@missFullCopies1
and
$@%¢exclude PT * $!
$@%¢missFullCopies2 8$!
commit;
--*********************************************************************
$@ if \ $isElar then $@=¢
--$'$$'r fehlende RecoveryBase Tablespaces, letzte 8 Tage:
$! $@ else $@=¢
--$'$$'s DXB - fehlende RecoveryBase Tablespaces, letzte 8 Tage:
$!
--*********************************************************************
$@% missBaseV2Beg older8d 8
and
$@% exclude = -vr *
$@% missBaseV2End
commit;
--*********************************************************************
--$'$$'r fehlende Fullcopies Indexspaces, letzte 8 Tage:
--************************************************************
SELECT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,SUBSTR(IX.DBNAME,1,8) AS DBNAME
,SUBSTR(IX.INDEXSPACE,1,8) AS IXSPACE
,IP.PARTITION
,DATE(IX.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
AND IX.COPY = 'Y'
AND IP.SPACE <> -1 -- defineNo is in space not spaceF|
and
$@%¢exclude IX * $!
AND NOT EXISTS (
$@%¢selFullCopy IX.DBNAME IX.INDEXSPACE IP.PARTITION 8$!
)
ORDER BY CREATOR, IXNAME, IP.PARTITION
WITH UR;
commit;
--************************************************************
--$'$$'s Imagecopy Datasets die nicht katalogisiert sind:
--************************************************************
WITH DS AS
(
SELECT DBNAME, TSNAME, DSNUM
,MAX(ICDATE) ICDATE
,MAX(JOBNAME)JOBNAME
,DSNAME
FROM SYSIBM.SYSCOPY C
WHERE ICTYPE IN ('F','I')
AND C.TIMESTAMP >= CURRENT TIMESTAMP - 21 DAYS
and
$@%¢exclude C K$!
GROUP BY DBNAME, TSNAME, DSNUM, DSNAME
)
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(TSNAME,1,8) AS TSNAME
,CHAR(DSNUM) AS PART
,ICDATE, JOBNAME, DSNAME
FROM DS
where S100447.DSLOCATE(DSNAME) IS NULL
ORDER BY DBNAME, TSNAME, PART
WITH UR;
commit;
$@ if wordPos($dbSys, DBOF) > 0 then $@=/conSuXBS/
--************************************************************
--$'$$'r fehlende Fullcopies XBS Tablespaces, letzte 2 Tage:
--************************************************************
$@% missBaseV2Beg older2d 2
and
$@%¢setQDbTs = -vr $!
$@predBE
$@% missBaseV2End
$*( old ???????
with p as
(
select p.dbName db, p.tsName ts, p.partition pa, p.createdTs paCre
from sysibm.sysTablePart p
where
p.space <> -1 -- define=no is in space not spaceF |
AND
$@%¢setQDbTs P$!
$@predBE
)
$@%¢missFullBase current timestamp - 2 days $!
;
???????? old $*)
commit;
$/conSuXBS/
$@ if $hasXDoc then $@=/conSumXDoc/
$@xDocUnlErr
$@xDocRecErr
$@ if $isElar then $@=¢
--************************************************************
--$'$$'r XB ndbs - nicht katalogisierte Unloads
--************************************************************
with s as
(
select db, ts, pa, stage || ' ' || staTb stage, unl
from oa1p.tqz005TecSvUnload
where unl <> '' and stage <> '-r'
)
select *
from s
where s100447.dslocate(unl) is null
order by db, ts, pa
;
$!
$/conSumXDoc/
$/genConSum/
$****************** generate DDLControl *******************************
$proc $@/genDDLCon/
$@%¢genId Control DDL $!
if $isElar then $@=/ddlElar/
--************************************************************
--$'$$' XB tablepaces mit > 200 Partitionen:
--************************************************************
select dbname, name, partitions
from sysibm.systablespace
where (partitions > 254 and dbName not like 'XB%')
or ( partitions > 200 and dbname like 'XB%'
$@¢ if $dbSys = 'DVBP' then $@#¢
and not ( -- Liste der 65 alten / temporären / fehlerhaften TS
-- mit > 200 Partitionen die wir nicht anzeigen
-- gemaess Absprache mit Elar vom 17.7.14
(dbName = 'XBCZ1001' and name in ('SHS0101$', 'SIT02001'
, 'SIT0201$', 'SPS0101$', 'SPS0301$'))
or (dbName = 'XBDJC001' and name in ('SDJC0041', 'SDJC0042'
, 'SDJC0043', 'SDJC004H', 'SDJC0051', 'SDJC0052', 'SDJC0053'
, 'SDJC005H', 'SDJC0061', 'SDJC0062', 'SDJC0063', 'SDJC006H'
, 'SDJC0071', 'SDJC0072', 'SDJC0073', 'SDJC007H', 'SDJC0081'
, 'SDJC0082', 'SDJC0083', 'SDJC008H'))
or (dbName = 'XBDJC002' and name in ('SDJC0101', 'SDJC0102'
, 'SDJC0103', 'SDJC010H', 'SDJC0111', 'SDJC0112', 'SDJC0113'
, 'SDJC011H'))
or (dbName = 'XBDPM001' and name in ('SDPM0021', 'SDPM0022'
, 'SDPM0023', 'SDPM002H'))
or (dbName = 'XBFC4001' and name in ('SFC40021', 'SFC40022'
, 'SFC40023', 'SFC4002H', 'SFC40031', 'SFC40032', 'SFC40033'
, 'SFC4003H', 'SFC40041', 'SFC40042', 'SFC40043', 'SFC4004H'
, 'SFC40051', 'SFC40052', 'SFC40053', 'SFC4005H', 'SFC40061'
, 'SFC40062', 'SFC40063', 'SFC4006H', 'SFC40071', 'SFC40072'
, 'SFC40073', 'SFC4007H'))
or (dbName = 'XBFC4002' and name in ('SFC40091', 'SFC40092'
, 'SFC40093', 'SFC4009H'))
)
$! $!
)
order by dbName, name
;
commit;
$/ddlElar/
$@=/ddlCon1/
--************************************************************
--$'$$' LOB-Tablespaces mit falschen Spezifikationen:
--************************************************************
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(NAME,1,8) AS TSNAME
,BPOOL
,LOG
FROM SYSIBM.SYSTABLESPACE S
WHERE TYPE = 'O'
AND (BPOOL NOT IN('BP8','BP32K') OR LOG = 'N')
and
$@%¢exclude S L$!
ORDER BY DBNAME, TSNAME
WITH UR
;
commit;
--************************************************************
--$'$$' Tablespaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(TS.DBNAME,1,8) AS DBNAME
,SUBSTR(TS.NAME,1,8) AS TSNAME
,TS.BPOOL
,SUBSTR(PT.STORNAME,1,8) AS STORNAME
,PT.STORTYPE
FROM SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE ts.dbNAME = PT.DBNAME
AND TS.NAME = PT.TSNAME
and
$@%¢exclude PT F$!
AND (TS.BPOOL = 'BP0'
OR PT.STORNAME <> 'GSMS'
OR PT.STORTYPE = 'E')
ORDER BY DBNAME, TSNAME
WITH UR;
commit;
--************************************************************
--$'$$' Indexspaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,IX.BPOOL
,SUBSTR(IP.STORNAME,1,8) AS STORNAME
,IP.STORTYPE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
and
$@%¢exclude IX F$!
AND (IX.BPOOL = 'BP0'
OR IP.STORNAME <> 'GSMS'
OR IP.STORTYPE = 'E')
ORDER BY CREATOR, IXNAME
WITH UR;
commit;
$@¢ if $isElarCont then
$@gttNdPa
$!
--************************************************************
--$'$$' tableParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(PT.DBNAME,1,8) "db"
,SUBSTR(PT.TSNAME,1,8) "ts"
,PT.PARTITION "part"
,pt.pQty "priQty"
,pt.sQty "secQty"
,r.extents
FROM
SYSIBM.SYSTableSpace ts
join SYSIBM.SYSTABLEPART pt
on pt.dbName = ts.dbName and pt.tsname = ts.name
left join sysibm.sysTableSpaceStats r
on pt.dbNAME = r.DBNAME
AND pt.tsName = r.NAME
AND ts.dbid = r.dbid
AND ts.psid = r.psid
AND pt.partition = r.partition
WHERE (pt.pQty <> -1 or pt.sQty <> -1 or r.extents > 500)
and
$@%¢exclude PT L$!
$@¢if $isElar then $@/elar7/
$@=¢
and (ts.dbName not like 'XB%'
$!
if $isElarCont then $@=¢
or ts.dbname in ( select db from session.ndPa )
$!
$@=¢
)
$! $/elar7/
$!
ORDER BY pt.DBNAME, pt.tsNAME, PT.PARTITION
fetch first 999 rows only
WITH UR;
commit;
--************************************************************
--$'$$' IndexParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(Ip.ixCREATOR,1,8) AS CREATOR
,SUBSTR(Ip.ixNAME,1,16) AS IXNAME
,IP.PARTITION
,ip.pQty "priQty"
,ip.sQty "secQty"
,ip.extents
FROM
SYSIBM.SYSINDEXES Ix
join SYSIBM.SYSINDEXPART IP
on ix.creator = ip.ixCreator and ix.name = ip.ixName
left join SYSIBM.SYSINDEXSpaceStats r
on ix.creator = r.creator and ix.name = r.creator
and ix.dbid = r.dbid and ix.isobid = r.isobid
and ip.partition = r.partition
WHERE (ip.pQty <> -1 or ip.sQty <> -1 or r.extents > 300)
and
$@%¢exclude IX L$!
$@¢ if $isElar then $@¢
$@=¢
and (ix.dbName not like 'XB%' -- bis drop elar alt ???
$!
if $isElarCont then $@=¢
or ix.dbname in ( select db from session.ndPa )
$!
$@=¢
)
$! $!
$!
order by ix.creator, ix.name, ip.partition
fetch first 999 rows only
WITH UR;
$/ddlCon1/
$/genDDLCon/
$****************** generate Excludes *********************************
$proc $@/exclude/
$*( exF K nicht Katalogisierte image Copy
L falsche spezifikation LOB usw
F Falsche spezifikation andere
T TecSv SQL
* alle anderen
$*)
parse upper arg , q exF
$@%¢setQDbTs - q$!
$=exF=- exF
$@=¢
----- begin @proc exclude: excludes --- $exF --------------------------
NOT ($db LIKE 'WKDB%') -- DB2 WORK DATABASE
AND NOT ($db LIKE '%MAREC%') -- marec generated
AND NOT ($db LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT ($db LIKE 'QTXDB%') -- test kidi63
and not translate($db, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT ($db LIKE 'DB2ALA%') -- marec generated
AND NOT ($db LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT ($db LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT ($db LIKE 'DB2PLAN%' -- explain tables
$@¢ if q <> 'IX' then $@=¢
and translate(left($ts, 7), '999999999AA', '012345678FG')
= 'A999999' -- user explain tables
$! else $@=¢
-- cannot exclude user explain tables ONLY for indexes
$! $!
)
$!
if pos($exF, 'FL') > 0 | $isTec then $@=¢
AND NOT ($db like 'DSN%')
$! else $@=¢
AND NOT ($db like 'DSNDB%') -- DB2 CATALOG
AND NOT ($db LIKE 'DSN8%') -- IBM TEST DB
AND NOT ($db = 'DSNTESQ') -- DB2 CATALOG CLONE
$!
if pos($exF, '*TK') > 0 & $q <> 'IX' then $@=¢
AND NOT ($db like 'CSQ%' AND $ts like 'TSBLOB%' )
-- M-QUEUE DATENBANK
$!
if pos($exF, 'FL') > 0 then $@=¢
AND NOT ($db = 'SYSIBMTA') -- engineering
AND NOT ($db = 'SYSIBMTS') -- engineering
AND NOT ($db like 'IDTA%') -- ibm tools
AND NOT ($db = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT ($db = 'DB2OSC') -- osc
AND NOT ($db like 'DSQ%') -- qmf databse
AND $db NOT IN ('DUTILTST','XSN8D71L','DB2XML')
$!
if wordPos($dbSys, 'DBTF') > 0 then $@=¢
AND NOT ($db LIKE 'DAU%') -- Schulung Gerrit
$!
if wordPos($dbSys, 'DX0G') > 0 then $@=¢
AND NOT ($db LIKE '%1P%') -- PROTOTYPEN
AND NOT ($db LIKE 'DXB%') -- PROTOTYPEN
AND NOT ($db LIKE 'DGDB%') -- PROTOTYPEN
$!
if $exF == 'L' then $@¢
$@=¢
AND $db NOT LIKE 'PTDB%'
$!
if $isTec then $@=¢
AND $db NOT LIKE 'BMC%'
AND $db NOT LIKE 'DCMN00%' --Hat cloneTable Alter aufwendig
$!
$! else $@/excludeNotL/
if wordPos($dbSys, 'DBOF') > 0 & $q <> 'IX',
& pos($exF, '*T') > 0 then $@¢
$@=¢
AND NOT ($db = 'XC01A1P' and $ts <> 'A500A'
and ($ts LIKE 'A2%'or $ts LIKE 'A5%'))
-- EOS: Armin Breyer
AND NOT ($db = 'XR01A1P' AND $ts LIKE 'A2%' )
-- ERET: Armin Breyer
$!
if $exF = 'T' & $dbSys == 'DBOF' & $rz \== 'RQ2' then $@=¢
AND NOT
$@predBE
$!
$!
if wordPos($rz, 'RZ4') > 0 & $exF == 'F' then $@¢
if $q == IX then $@=¢
AND NOT $db = 'DB2PMPDB' -- PMON KITD2
$! else $@=¢
AND NOT ($db = 'DB2PMPDB'
AND $ts like 'ACCS%') -- PMON KITD2
AND NOT ($db = 'AC04A1P' AND $ts = 'SAC041A' ) -- ACF Gründler
$!
$!
if $dbSys = 'DP4G' then $@=¢
AND NOT $db in ('DB2PDB', 'DB2PDB2', 'DB2PDB3') -- performance DB
$!
if $dbSys = 'DBOC' then $@=¢
AND NOT ($db = 'DB2PDB') -- performance DB
AND NOT ($db = 'DB2XML') -- performance DB
$!
if $isElar then $@¢
if $exF == 'K' then $@=¢
and not ($q.dsName like 'XB.DIV.P0.%' -- bis drop elar alt ???
and translate(strip($q.dsName), '999999999', '012345678')
like '%.APROC.G9999V99' )
$! else $@=¢
AND NOT ($db LIKE 'XB%') -- ELAR Dokumente
$!
$!
$/excludeNotL/
$@=¢
----- end @proc exclude: excludes --- $exF --------------------------
$!
$/exclude/
$****************** set vars q, db and ts ******************************
$proc $@/setQDbTs/
parse arg , q
hasQual = \ abbrev(q, '-')
q = strip(translate(q, ' ', '-'))
$= q =- q
quD = copies(q'.', hasQual)
upper q
$=db =- quD'dbName'
if q == 'S' then $@¢
$= ts =- quD'name'
$! else if q == 'IX' then $@¢
$= ts = ???noTs???
$! else if q == 'VR' then $@¢
$= db =- quD'db'
$= ts =- quD'ts'
$! else $@=¢
$= ts =- quD'tsName'
$!
$/setQDbTs/
$****************** BE save *******************************************
$proc $@=/predBE/
($db = 'BE01A1P' and $ts like 'A0%' -- BE save
or $db = 'CD02A1P' and $ts = 'A600A')
$/predBE/
$****************** missing fullcopies alt ****************************
$proc $@=/missFullCopies1/
---- begin @proc missFullCopies1: fehlende Fullcopies -----------------
SELECT SUBSTR(PT.DBNAME,1,8) AS DBNAME
,SUBSTR(PT.TSNAME,1,8) AS TSNAME
,PT.PARTITION
,DATE(TS.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE ts.dbNAME = pt.DBNAME
AND TS.NAME = PT.TSNAME
---- end @proc missFullCopies1: fehlende Fullcopies -----------------
$/missFullCopies1/
$proc $@/missFullCopies2/
parse arg , days
$@=¢
---- begin @proc missFullCopies2: fehlende Fullcopies -----------------
AND TS.NTABLES <> 0
AND PT.SPACE <> -1 -- define no is only in space not spaceF |
AND NOT EXISTS (
$@%¢selFullCopy - PT.DBNAME PT.TSNAME PT.PARTITION arg(2)$!
)
ORDER BY DBNAME, TSNAME, PT.PARTITION
WITH UR;
---- end @proc missFullCopies2: fehlende Fullcopies -----------------
$!
$/missFullCopies2/
$proc $@/selFullCopy/
parse arg , db ts part days
$@=¢
---- begin @proc selFUllCopy: select fullcopy etc. --------------------
SELECT ' '
FROM SYSIBM.SYSCOPY CP
WHERE $-¢db$! = CP.DBNAME
AND $-¢ts$! = CP.TSNAME
AND cp.dsNum in ($-¢part$!, 0)
-- fullcopy or fullLog
AND (( CP.ICTYPE IN ('F','R','X') -- fullcopy or fullLog
AND CP.TIMESTAMP > CURRENT TIMESTAMP - $-¢days$! DAYS
) or ((CP.ICTYPE = 'C' -- created today
-- part added today
or (CP.ICTYPE = 'A' and CP.sType = 'A')
) and date(cp.timestamp) >= current date
) )
---- end @proc selFUllCopy: select fullcopy etc. --------------------
$!
$/selFullCopy/
$****************** missing fullcopies neu ****************************
$@proc $@=/sesCopy/
--- temporary table fuer syscopy -------------------------------------
declare global temporary table session.copy
( db char(8), ts char(8), inst smallint, pa smallInt
, fulTy char(1), fulTst timestamp, fulPa smallInt
, incTy char(1), incTst timestamp, incPa smallInt
) on commit preserve rows;
create unique index session.txIx on session.copy
(db,ts, inst, pa)
include (fulTy, incTy, fulPa, fulTst)
;
select current timestamp from sysibm.sysDummy1;
insert into session.copy
with dsn_inline_opt_hint (table_name, join_method) as
(
values ('L2', 'SMJ')
)
, l1 (db, ts, inst, pa, ful, inc) as
(
select dbName, tsName, instance, dsNum
, max(case when ICTYPE IN ( $icTyBase
, $icTyDisc)
and not (ICTYPE = 'A' and sType <> 'A') -- part added
then char(timestamp) || c.icType || char(c.dsNum)
else '' end )
, max(case when ICTYPE IN ('I')
then char(timestamp) || c.icType || char(c.dsNum)
else '' end )
from sysibm.syscopy c
-- where timestamp > current timestamp - 50 days ?????
group by dbName, tsName, dsNum, instance
)
, l2 (db, ts, pa, inst, ful, inc) as
(
select * from l1
where ful <> '' or inc <> ''
)
, l3 (db, ts, inst, pa, ful, inc) as
(
select l.db, l.ts, l.inst, l.pa
, max(value(l.ful, ''), value(r.ful, '')
, '1111-11-11-11.11.11.111111 -99')
, max(value(l.inc, ''), value(l.ful, '')
, value(r.inc, ''), value(r.ful, '')
, '1111-11-11-11.11.11.111111 -99')
from l2 l
left join l2 r
on l.pa > 0 and r.pa = 0
and l.db = r.db and l.ts = r.ts and l.inst = r.inst
)
, laCo (db, ts, inst, pa, fulTy, fulTst, fulPa, incTy, incTst, incPa) as
(
select db, ts, pa, inst
, substr(ful, 27, 1)
, timestamp(left(ful, 26))
, smallInt(substr(ful, 28))
, substr(inc, 27, 1)
, timestamp(left(inc, 26))
, smallInt(substr(inc, 28))
from l3
)
select * from laCo
;
commit
;
select current timestamp from sysibm.sysDummy1;
$*(
;X;ect count(*) from laCo with ur;
insert into session.copy
with l as
(
select c.dbName db, c.tsName ts, c.instance inst
, c.dsNum, c.icType, c.timestamp tst
, case when s.partitions = 0 then 0
when c.lowDsNum <= 0 then c.dsNum
when c.highDsNum <= 0 then c.dsNum
else c.lowDsNum
end paFr
, case when s.partitions = 0 then 0
when c.lowDsNum <= 0 then c.dsNum
when c.highDsNum <= 0 then c.dsNum
else c.highDsNum
end paTo
from sysibm.sysCopy c
join sysibm.sysTableSpace s
on c.dbName = s.dbName and c.tsName = s.name
where ICTYPE IN ('A' ,'C', 'F', 'S', 'W', 'Y')
and not (ICTYPE = 'A' and sType <> 'A') -- part added
and not (ICTYPE in ('S', 'W', 'Y')
and timestamp > current timestamp - $logDisDelta)
)
, g as
(
select db, ts, inst, paFr, paTo
, max(char(tst) || ictype || dsNum) last
from l
group by db, ts, inst, paFr, paTo
)
select db, ts, inst, paFr, paTo
, smallInt(substr(last, 28)) dsNum
, substr(last, 27, 1) icType
, timestamp(substr(last, 1, 26)) tst
from g
;
$*)
select count(*) "copy count"
, count(distinct db || '.' || ts) "copy TS's"
, count(distinct db ) "copy DB's"
from session.copy
;
commit;
--*********************************************************************
--$'$$'s fehlende Fullcopies/Recoverybases, letzte 8 Tage $xDocNoTx
--*********************************************************************
with p as
(
select p.dbName db, p.tsName ts, p.partition pa, p.createdTs paCre
from sysibm.sysTablePart p
where
p.space <> -1 -- define=no is in space only not spaceF |
and
$@%¢exclude P * $!
)
$@%¢missFullBase current timestamp - 8 days $!
;
commit;
$/sesCopy/
$proc $@=/missFullB1/
, i(c, s, i, clBa, inTx) as
( select 'N', 1, 1, ' ', '' from sysibm.sysDummy1
union all select 'N', 2, 2, ' ', '2 only' from sysibm.sysDummy1
union all select 'Y', 1, 1, 'b', '1 base' from sysibm.sysDummy1
union all select 'Y', 1, 2, 'c', '2 clone' from sysibm.sysDummy1
union all select 'Y', 2, 1, 'c', '1 clone' from sysibm.sysDummy1
union all select 'Y', 2, 2, 'b', '2 base' from sysibm.sysDummy1
)
, l as
(
select p.*
, case when i.i is not null then i.i
else raise_error(70001, 'bad clone ' || s.clone) end inst
, i.inTx
, value(c.fulTy, ' ') fulTy
, value(c.fulPa, -99) fulPa
, value(c.fulTst, '1111-11-11-11.11.11') fulTst
, $@%¢icTyTx value(c.fulTy, ' ') $!
fulTx
, value(c.incTy, ' ') incTy
, value(c.incPa, -99) incPa
, value(c.incTst, '1111-11-11-11.11.11') incTst
, $@%¢icTyTx value(c.incTy, ' ') $!
incTx
, s.dbid, s.psid
from p
join sysibm.sysTablespace s
on p.db = s.dbName and p.ts = s.name
and s.ntables <> 0
join i on i.c = s.clone and i.s = s.instance
left join session.copy c
on c.db = p.db and c.ts = p.ts and c.inst = i.i and c.pa = p.pa
)
$/missFullB1/
$proc $@=/missFullBase/
$arg dayLim
$@missFullB1
select substr(db, 1, 8) db
, substr(left(ts, 8) || ' ' || inTx, 1, 16) "ts instanc"
, substr(right(' ' || pa, 5) || right(' ' || dsNum, 5)
, 1, 10) " part dsNu"
, coalesce(iTx, ty) "icType"
, tst
from m
left join ict on iTy = ty
where ty is null or not
((ty = 'F' and tst
> $dayLim)
or (paCre > current timestamp - 24 hours))
order by 1, 2, 3
with ur
$/missFullBase/
$proc $@=/genBesenWagen/
$@% genId BesenWagen $xDocTx
$@xDocUnlErr
$@xDocRecErr
--*********************************************************************
--FixBesenwagen fuer $xDocTx
--*********************************************************************
with x as -- without with sql -101 sql too complex .....
(
select db, ts, pa, stage, staTb, conSum, basTst, recFun
, max(pSpc, rSpc, 0) spc, recov
$@xDocVRecovLoad
order by value(pSpc, 0), db, ts, pa
)
select char(db, 8) db, char(ts, 8) ts, pa
, substr(fosFmte7(spc * 1024.0), 1, 7) spaceB
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(conSum, 1, 40) recoveryState
from x
where recFun = '?'
and not ( (recov='ok' and basTst > current timestamp - 14 days)
$@ if $isElar then $@=¢
or stage in ('-w', 'UL', 'DL')
-- or erRec like '%notInDB2%'
-- or erRec like '%dataChangeV11%' -- only if dataChange>
$! $@ else $@=¢
-- or erRec like '%copyUpdate>incTst%' -- only if >fulTst
-- or erRec like '%dataChangeV11>unl%'--only if dataCange>
-- or erRec like '%inc180515>unl%' -- err in tecSv
or conSum like '? inc180515>unl%'
$!
)
;
$/genBesenWagen/
$****************** missing Recover Base Version sept 15 **************
$proc $@=/missBaseV2Beg/
$arg txtLim dayLim
SELECT SUBSTR(db, 1, 8) db
, SUBSTR(ts,1,8) ts
, pa as PART
, case when recov = 'ok' then '$txtLim' else recov end recov
, basTyTx
, basPa
, basTst
from oa1p.vQz005Recover
WHERE ( recov not in ('ok', 'defNo', 'noTb')
or ( recov = 'ok' and basTst
< current timestamp - $dayLim days )
)
$/missBaseV2Beg/
$proc $@=/missBaseV2End/
order by 1, 2, 3
with ur
;
$/missBaseV2End/
$proc $@=/xDocRecErr/
--*********************************************************************
-- $xDocTx: Summary fehlende Recoverybases / Unloads
--*********************************************************************
with z as
(
select r.*
, case when recLR = '2' and recFun = 'r'
then conSum || ' ' || recUnl else conSum end conSu2
, max(pSpc, rSpc, 0) spc
$@xDocVRecovLoad
)
select substr(fosFmtE7(sum(spc) * 1024.0)
|| right(' ' || count(*), 8), 1, 15)
"spaceBy count"
, stage
, substr(conSu2, 1, 70) recoveryState
from z
group by stage, conSu2
order by 2, 3
--
-- columns
$@ if $isElar then $@=¢
-- stage: ' ' non document tables in XC/XR DBs
$! $@ else $@=¢
-- stage: '-m' missing in stage tables
-- '-a' registered only in txba201
-- '-w' www tables
$!
-- recoveryState:
-- substr(1, 1) recover by
-- 'r' db2 recovery from imageCopy and db2Log
-- 'l' load unload dsn
-- '?' recovery not possible / doubtful
-- substr(3...) recover state / warning / error
;
--*********************************************************************
--$'$$'s fehlende Fullcopies/Recoverybases, letzte 8 Tage $xDocTx
--*********************************************************************
with z as
(
select r.*
, case when recLR = '2' and recFun = 'r'
then conSum || ' ' || recUnl else conSum end conSu2
$@xDocVRecovLoad
order by db, ts, pa
)
select char(db, 8) db, char(ts, 8) ts, pa
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(conSu2, 1, 40) err
, substr(case when basTy <> ' '
then basTy || ' ' || char(basTst) else '' end, 1, 21)
"last fullCopy"
, substr(case when unl <> '' then char(unlTst) else '' end
, 1, 10) "unload"
-- , z.*
from z
where recFun = '?'
$@ if $isElar then $@=¢
and stage not in ('-w')
$!
$@stageInfo
;
$/xDocRecErr/
$proc $@=/xDocUnlErr/
--************************************************************
-- Statistik unload table $xDocBrTx
--************************************************************
$@xDocUnlUE
select stage "stage"
, count(*) "#parts"
, smallInt(count(distinct db || '.' || ts)) "#ts"
, substr(err, 1, 75) "error / info"
from uE
group by stage, err
order by case when stage = '-r' then 0 else 1 end, stage, err
;
$@ if $isElar then $@=¢
--- elar NDBS: neuer Elar Design seit 2013/14 -------------------------
$! $@ else $@=¢
--- XC/XR Kontrolle AuditPendenz 2015 ---------------------------------
$!
--************************************************************
--$'$$'r $xDocTx Fehler in stageTables
--************************************************************
$@xDocUnlUE
select db, ts
, substr(right(' ' || pa, 5), 1, 5) part
, stage || ' ' || staTb
, substr(err, 1, 36) err
, substr(unl, 1, 41) unl
from uE
where err <> '' and not (db = '' and pa < -100)
order by case when stage = '-r' then 0 else 1 end, db, ts, pa
$@stageInfo
;
commit;
$/xDocUnlErr/
$proc $@=/xDocUnlUE/
with uE (db, ts, pa, stage, staTb, unl, err) as
(
select db, ts, pa, stage, staTb, unl
, strip(case
$@ if $isElar then $@=¢
when stage not in ('RW', 'CL', 'UL', 'DL'
, '-m', '-a', '-w', '-r') then ' badStage=' || stage
when unl <> '' and stage in ('RW')
then ' unloadInStage=' || stage
$! $@ else $@=¢
when stage not in ('IN', 'RU', 'FZ', 'UL', 'MI', '-r')
then ' badStage=' || stage
when unl <> '' and stage in ('RU', 'MI')
then ' unloadInStage=' || stage
$!
else ''
end || ' ' || err) ee
from oa1p.tqz005tecsvunload u
where db <> ''
union all select db, ts,-101, stage, staTb, unl
, 'refresh from ' || left(char(unlTst), 19)
|| ' to ' || left(char(punTst), 19)
from oa1p.tqz005tecsvunload u
where db = '' and ts = ''
union all select db, ts,-101, stage, staTb, unl
, 'refresh info ' || info
from oa1p.tqz005tecsvunload u
where db = '' and ts = ''
union all select db, ts,-101, stage, staTb, unl, err
from oa1p.tqz005tecsvunload u
where db = '' and ts = '' and err <> ''
union all select db, ts, pa, stage, staTb
, char(unlTst), 'refresh older 3h'
from oa1p.tqz005tecsvunload
where db='' and ts='' and pa=-99
and unlTst < current timestamp - 3 hours
union all select '', '', -99, '-r', '', '', count(*) ||' refresh rows'
from oa1p.tqz005tecsvunload
where db='' and ts='' and pa=-99 and stage = '-r'
having count(*) <> 1
)
$/xDocUnlUE/
$proc $@=/xDocVRecovLoad/
$@ if $useLgRn then $@=¢
from oa1p.vQz005RecovLoadLgRn r
$! $@ else $@=¢
from oa1p.vQz005RecovLoad r
$!
$@ if $isElar then $@=¢
where db like 'XB%'
$! $@ else $@=¢
where (db like 'XC%' or db like 'XR%')
$!
$/xDocVRecovLoad/
$proc $@=/stageInfo/
-- stage: substr(1,2) = stage
-- substr(4,2) = stageTables
$@ if $isElar then $@=¢
-- i = BUA.TXBI003 segment table
-- a = bua.txba201
-- c = BUA.TXBC021 unload table
-- s = BUA.TXBC021s unload table
$! $@ else $@=¢
-- 1 = OA1P.TXC106A1 EOS alt ==> OA1P??.TXC200A1
-- 4 = OA1P.TXC406A1 eRet AFP ==> OA1P.TXC501A1+502A1
-- EOS PDF ==> OA1P.TXC51*A1
-- r = OA1P.TXR106A1 eRet ==> OA1P.TXR200A1+201A1
$!
$/stageInfo/
$proc $@=/missFullBaUnl/
with p as
(
select db, ts, pa, stage, staUpd, staTb
, unlTst, unl, punTst pun
, info infoP
, err errUnl
, p.space pSpc
from oa1p.tqz005TecSvUnload u
join sysibm.sysTablePart p
on u.db = p.dbName and u.ts = p.tsName and u.pa = p.partition
where pa >= 0
$@ if $isElar then $@=¢
and ts not in -- gestoppte TS, im Loeschprozess
( 'SF710141'
, 'SF710142'
, 'SF710143'
, 'SF71014H'
, 'SF760141'
, 'SF760142'
, 'SF760143'
, 'SF76014H'
)
$!
)
$@missFullB1
, eR as -- error for db2Recovery oder unloadRecovery
(
select
case when l.pSpc = -1 then '' -- define no = no vsam
when fulTy not in ($icTyBase)
then 'lastFul=' || fulTx
when fulTst < current timestamp - 15 days
then 'fulTst<-15d'
when fulTst < current timestamp - 8 days
then 'fulTst<-8d'
when r.dbName is null then 'noRTS'
else ''
end erReD
, strip(case
when unl is null or unl = '' then 'noUnload'
when unlTst is null or unlTst < current timestamp - 100 years
then 'unlTstNull'
when r.dbName is null then 'noRTS'
when r.lastDataChange > l.unlTst then 'dataChange>unl'
when r.copyUpdatetime > unlTst then 'copyUpdate>unlTst'
when fulTst > unlTst
$@ if \ $isElar then $@=¢
and (date(incTst) <> '18.05.2015' or fulTy <> 'F')
$!
then 'unlTst<ful='||fulTx
when incTst > unlTst and incTy='I'
$@ if \ $isElar then $@=¢
and date(incTst) <> '18.05.2015'
$!
then 'unlTst<inc='||incTx
when r.copyChanges <> 0 then 'copyChanges<>0'
when r.copyUpdatedPages <> 0 then 'updatedPages<>0'
$*(
when r.copyUpdatetime > fulTst and fulTy = 'F'
then 'copyUpdate>ful='||fulTx
when r.copyUpdatetime > incTst and incTy = 'I'
then 'copyUpdate>inc='||incTx
$*)
when r.copyUpdatetime is not null then 'copyUpdateNotNull'
when r.lastDataChange > l.fulTst and l.fulTy not in('A',' ')
$@ if \ $isElar then $@=¢
and unlTst > '2015-09-12-12.00.00'
$!
then 'dataChange>ful='||fulTx
when fulTy <> 'F' then 'lastFul=' || fulTx
$*(
$@ if $isElar then $@=¢
when incTy = 'I' and incTst > '2015-09-12-12.00.00'
then 'lastInc1509=' || incTx
$!
$*)
when incTst > unlTst
$@ if \ $isElar then $@=¢
and date(incTst) <> '18.05.2015'
$!
then 'incTst>unlTst'
when r.lastDataChange is null and unlTst
< '2015-04-15-00.00.00' then 'dataChangeV11>unl'
when lastDataChange is null
and l.incTst < '2015-04-15-00.00.00'
then 'dataChangeV11>inc=' || incTx
$@ if \ $isElar then $@=¢
when incTst > unlTst
and date(incTst) = '18.05.2015'
then 'inc180515>unl'
$!
else ''
$@ if $useLgRn then $@=¢
end || case
when unl is null or unl = '' or unlTst is null
or unlTst < current timestamp - 100 years then ''
when lr.start > unlTst then ' lgRn>unl'
when lr.start is null then ' lgRnNone'
else ''
$!
end) erReU, l.*, r.*
from l left join sysibm.sysTableSpaceStats r
on l.dbId = r.dbId and l.psId = r.psId
and l.pa = r.partition and l.inst = r.instance
and l.db = r.dbName and l.ts = r.name
$@ if $useLgRn then $@=¢
left join oa1p.tqz004TecSvLgRn lr
on l.db = lr.db and l.ts = lr.ts and l.pa = lr.pa
$!
)
, e as
(
select eR.*
, strip(case
$@ if $isElar then $@=¢
-- when stage = ' w' then ''
when stage in ('UL', 'DL', ' w') and erReU <> ''
then erReU
when stage in ('UL', 'DL', ' w') then ''
when erReD <> '' then erReD
$! $@ else $@=¢
when stage in ('IN', 'UL')
and erReD <> '' and erReU <> ''
then erReU || ' ' || erReD
when stage = 'IN' and unl <> '' and (staUpd is null
or staUpd < current timestamp - 24 hour)
then 'stillUnlAft24h'
when stage not in ('IN', 'UL') and erReD <> '' then erReD
$!
else ''
end ) erRec
from eR
)
$/missFullBaUnl/
$proc $@=/xDocRecErrV1/
--*********************************************************************
--Summary fehlende Fullcopies/Recoverybases, letzte 8 Tage $xDocBrTx
--*********************************************************************
$@missFullBaUnl
select count(*), stage
, substr(strip(erRec || ' ' || errUnl), 1, 70) err
-- , min(err), max(err)
-- , min(unl), max(unl)
from e
group by stage, strip(erRec || ' ' || errUnl)
order by 2, 3
;
--*********************************************************************
--$'$$'s fehlende Fullcopies/Recoverybases, letzte 8 Tage $xDocBrTx
--*********************************************************************
$@missFullBaUnl
select db, ts, pa
, substr(left(stage, 2) || ' ' || staTb, 1 , 5) stage
, substr(strip(erRec || ' ' || errUnl), 1, 40) err
, substr(case when fulTy <> ' '
then fulTy || ' ' || char(fulTst) else '' end, 1, 21)
"last fullCopy"
, substr(case when unl <> '' then char(unlTst) else '' end
, 1, 10) "unload"
-- , e.*
from e
where not (erRec = ''
$@ if $isElar then $@=¢
or stage in (' w')
or erRec like '%dataChangeV11%' -- only if dataCange>
or ( stage in ('UL', 'DL')
and ( erRec like '%lastFul= =missi%'
or erRec like '%lastFul=A=addPa%'
or erRec like '%lastFul=S=LoaRp%'
or erRec like '%lastFul=Y=LoaRs%'
) )
$! $@ else $@=¢
or erRec like '%copyUpdate>incTst%' -- only if >fulTst
or erRec like '%dataChangeV11>unl%' -- only if dataCange>
or erRec like '%inc180515>unl%' -- err in tecSv
$!
)
order by db, ts, pa
--
-- columns
$@stageInfo
-- last fullcopy: icType und timestamp
-- unload : Datum
;
$*( ???????????? altes ndbs
--*********************************************************************
--$'$$'r XB ndbs - fehlende Fullcopi/Recoverybase, letzte 8 Tage:
--*********************************************************************
with p as
(
select n.*, p.createdTs paCre
from session.ndPa n
join sysibm.sysTablePart p
on n.db = p.dbName and n.ts = p.tsName and n.pa = p.partition
and p.space <> -1 -- define=no is in space not spaceF |
where stage not in ('UL', 'DL')
)
$@%¢missFullBase 1 current timestamp - 8 days $!
;
commit;
--*********************************************************************
-- ndbs: temporary table für unloads
declare global temporary table session.unl
( db char(8), ts char(8), pa smallint, unl char(44), err varChar(30)
) on commit preserve rows;
create unique index session.unlIx on session.unl (db,ts, pa)
include (unl)
;
insert into session.unl
with f as
(
select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa, eaRess, '1' ptb
from BUA.TXBC021 t
where EYRESS = 5000 and ESRESS = 0
union all select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa, eaRess, 's' ptb
from BUA.TXBC021s t
where EYRESS = 5000 and ESRESS = 0
)
, g as
(
select db, ts, pa, min(eaRess) eaRess, count(*) cnt
, min(pTb) || '+' || max(pTb) pTb
from f
group by db, ts, pa
)
select db, ts, pa, eaRess
, case when earess not like 'XB.XB%'
then 'eaRess not XB.XB% ' || pTb
when locate('.', earess, 4) <> 12
then 'eaRess db len ' || pTb
when locate('.', earess, 13) not between 14 and 21
then 'eaRess ts len ' || pTb
when cnt <> 1 then 'duplicates ' || cnt || ' ' || pTb
else '' end err
from g
with cs
;
commit;
--************************************************************
--$'$$'r XB ndbs - ungueltige Einträge in BUA.TXBC021/S
--************************************************************
select *
from session.unl
where err <> ''
order by db, ts, pa
;
--************************************************************
--$'$$'r XB ndbs - fehlende unloads fuer stage UL
--************************************************************
select p.*
from session.ndPa p
left join session.unl u
on p.db = u.db and p.ts = u.ts and p.pa = u.pa
where stage = 'UL' and u.db is null
order by db, ts, pa
;
--************************************************************
--$'$$'r XB ndbs - nicht katalogisierte Unloads
--************************************************************
select p.db, p.ts, p.pa, p.stage, u.unl
from session.ndPa p
join session.unl u
on p.db = u.db and p.ts = u.ts and p.pa = u.pa
and p.stage = 'UL'
where s100447.dslocate(unl) is null
order by db, ts, pa
;
commit;
????????? altes NDBS $*)
$/xDocRecErrV1/
$proc $@=/icTyTx/
$arg tyCo
$ct icTyBase = 'A','C','F','R','X' $** recovery base
$ct icTyDisc = 'P','S','W','Y' $** recovery discontinuty
value($tyCo || '='
|| case $tyCo
when ' ' then 'missing'
when 'A' then 'addPart'
when 'C' then 'create'
when 'F' then 'fulCopy'
when 'I' then 'incCopy'
when 'P' then 'recPIT'
when 'R' then 'LoaRpLog'
when 'S' then 'LoaRpLoNo'
when 'W' then 'ReorgLoNo'
when 'X' then 'ReorgLog'
when 'Y' then 'LoaRsLoNo'
else '???'
end, '-=null')
$/icTyTx/
$****************** create and fill gtt if not done yet ***************
$proc $@/gttNdPa/
if \ $gttNdPaDone then $@=/gttNdPaSql/
$= gttNdPaDone = 1
--- global table fuer Partitionen, stage, segment ---------------------
declare global temporary table session.ndPa
( db char(8), ts char(8), pa smallInt, stage char(2), seg char(6)
) on commit preserve rows;
create unique index session.ndPaIx on session.ndPa (db,ts, pa)
include (stage, seg)
;
insert into session.ndPa
select t.dbName, t.tsName
, r.partNumber, r.stage, r.storageArea || r.segment
FROM sysibm.systables t
join BUA.TXBI003 R
on substr(t.name, 3, 3) = r.storageArea
and substr(t.name, 6, 3) = r.segment
where t.creator = 'BUA'
and t.name like 'XB%'
;
commit
;
--- counts fuer ndbs --------------------------------------------------
select count(*) "ndbs Parts"
, count(distinct db || '.' || ts) "ndbs TS's"
, count(distinct db ) "ndbs DB's"
from session.ndPa
;
commit
;
$/gttNdPaSql/
$/gttNdPa/
$****************** tecSave sql ***************************************
$proc $@=/tecSvSql/
$@¢
parse arg , tsF tit
$=tsF=- tsF
if tsF == 'i' then $@¢
$=tsTxt = incremental
$! else if tsF == 'f' then $@¢
$=tsTxt = full
$! else $@¢
call err 'bad fun tsF' tsF 'in tecSvSql'
$!
$!
#HCCD (TS) RTS $tsTxt IMAGE COPY
$@%¢genId3 - tit$!
SELECT 'DI,PI,PA,IN' , DBID , PSID , PARTITION , INST
from
( select ts.dbName, ts.name, p.partition
, c.inst, ts.dbid, ts.psid
, overlay(case
when c.inst is null
then raise_Error(70001, 'c.inst null '
|| ts.dbName || '.' || ts.name)
when ts.nTables < 1 then 'n noTables ' || ts.nTables
when p.space = -1 then 'n defineNo ' || p.space
$** let utility figure out define no or yes
$** but dbAnalyzer always produces RTS not found messages
$** ==> unfortunately not a good idea |
when f.icType is null then 'f f.icType null'
when f.icType <> 'F' then 'f f.icType ' || f.icType
when f.dsNum <> p.partition then 'f multiPart'
when f.timestamp < current timestamp-7 days then 'f week'
when r.updateStatsTime is null then 'f noRts'
when r.copyLastTime is null then 'f r.copyLast null'
when i.timestamp < r.copyLastTime - 60 seconds
then 'f i << r.copyLast'
when r.nactive * 0.1 <= r.copyupdatedpages
then 'f updates'
when i.icType is null then 'f i.icType null'
when i.icType not in ('I','F') then 'i i.icType '||i.icType
when r.copyupdatedpages <> 0 then 'i updates'
when r.copyChanges <> 0 then 'i changes'
when r.copyUpdateLRSN is not null then 'i updLRSN'
when r.copyUpdateTime is not null then 'i updTime'
else 'n noUpdates'
end, case when ts.clone <> 'Y' then ' '
when ts.instance = c.inst then ' base '
else ' clone'
end, 2, 0, octets) what
from sysibm.sysTablespace ts
left join -- clone handling: add instances
( select 1 from sysibm.sysDummy1
union all select 2 from sysibm.sysDummy1
) c (inst)
on ts.instance = c.inst or ts.clone = 'Y'
join sysibm.sysTablePart p
on ts.dbName = p.dbName and ts.name = p.tsName
left join sysibm.sysTableSpaceStats r
on ts.dbName = r.dbName and ts.name = r.name
and ts.dbid = r.dbid and ts.psid = r.psid
and p.partition = r.partition and r.instance = c.inst
left join -- newest incremental or full copy or log discontinuity
( select c.*
, row_number() over(partition by dbName, tsName, dsNum
, instance
order by timestamp desc) rn
from sysibm.sysCopy c
where c.icType not IN ('A', 'B', 'C', 'D', 'M', 'Q')
) i on i.rn = 1
and ts.dbName = i.dbName and ts.Name = i.tsName
and p.partition = i.dsNum
and i.instance = c.inst
left join -- newest full copy or log discontinuity
( select c.*
, row_number() over(partition by dbName, tsName, dsNum
, instance
order by timestamp desc) rn
from sysibm.sysCopy c
where c.icType not IN ('A', 'B', 'C', 'D', 'I', 'M', 'Q')
) f on f.rn = 1
and ts.dbName = f.dbName and ts.Name = f.tsName
and p.partition = f.dsNum
and f.instance = c.inst
) s
where what like '$tsF%%' $** doppelte % fuer ca dbAnalyser
and
$/tecSvSql/
$proc $@=/copyArc0/
$** currently always empty
$/copyArc0/
$proc $@=/copyArc1/
$= cre =- if($dbSys == 'DBTF', 'OA1T', 'OA1P')
SELECT CURRENT TIMESTAMP - 3 MINUTES,
CHAR(' SUB#ADB1 $cre.TADM62A1 ', 50)
FROM SYSIBM.SYSDUMMY1
;
SELECT C.DBNAME, C.TSNAME, C.DSNUM, C.TIMESTAMP, C.ICTYPE, C.DSNAME,
CHAR(C.COPYPAGESF * 1024 * S.PGSIZE) COPIED
FROM SYSIBM.SYSCOPY C, SYSIBM.SYSTABLESPACE S
WHERE C.ICTYPE IN ('F', 'I')
AND S.DBNAME = C.DBNAME
AND S.NAME = C.TSNAME
$@¢ if wordPos($dbSys, 'DX0G DVTB') > 0 then $@=¢
AND S.DBNAME = ' no no'
$! $!
ORDER BY 1, 2, 3, 4 DESC
WITH UR
;
$/copyArc1/
$#out 20150923 09:11:33
}¢--- A540769.WK.REXX(CONSUMXB) cre=2015-05-21 mod=2015-05-22-10.29.52 A540769 ---
declare global temporary table session.unl
( db char(8), ts char(8), pa smallint, sta char(2)
, unl char(44), info varChar(70), err varchar(20)
) on commit preserve rows
;
create unique index session.unlIx on session.unl (db,ts, pa)
include (sta, unl)
;
insert into session.unl
with s as
( -- stage & info from TXBI003
select t.dbName db, t.tsName ts, r.partNumber pa
, value(r.stage, '') sta
, 'xb ' || storageArea || '#' || r.segment
|| ' ' || char(date(lastImport))
|| ' ' || strip(objectFamily) || '@' || bu info
FROM sysibm.systables t
join BUA.TXBI003 r -- storageArea and segment
-- are part of tableName
on substr(t.name, 3, 3) = r.storageArea
and substr(t.name, 6, 3) = r.segment
and t.creator = 'BUA'
and t.name like 'XB%'
)
, e as
( -- unloads from TXBC021 and TXBC021S
-- decode db and ts from unload DSN
select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa
, value(eaRess, '') unl
, '1' uTb
from BUA.TXBC021 t
where EYRESS = 5000 and ESRESS = 0
union all select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa
, value(eaRess, '') unl
, 's' uTb
from BUA.TXBC021s t
where EYRESS = 5000 and ESRESS = 0
)
, u (db, ts, pa, sta, unl, info) as
(
select -- join stage and unloads
value(s.db, e.db) db
, value(s.ts, e.ts) ts
, value(s.pa, e.pa) pa
, s.sta
, e.unl
, value(s.info, '') || value(' u=' || e.uTb, '')
from s full outer join e
on s.db = e.db and s.ts = e.ts and s.pa = e.pa
-- the migration tables %WWW%
-- have no entries in the above tables
-- however, Kiran will do an unload|
union all select t.dbName, t.tsName, p.partition, 'ww'
, 'XB.' || t.dbName || '.' || t.tsName
|| '.P'|| right('00000' || partition, 5) || '.WWW?llq'
, 'www'
from sysibm.sysTables t join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
where t.dbName like 'XB%'
and (t.tsName like '%WWW%' or t.name like '%WWW%')
)
select db, ts, pa
, min(sta) sta
, min(unl) unl
, min(info) info
-- more than one unload per part?
, case when count(*) <> 1
then ', ' || count(*) || ' unloads' else '' end err
from u
group by db, ts, pa
;
commit
;
--- counts fuer unloads -----------------------------------------------
select count(*) "#parts"
, count(distinct db || '.' || ts) "#TS"
, count(distinct db ) "#DB"
, sum(case when unl is null or unl = '' then 0 else 1 end) "#unl"
, sum(case when sta = 'ww' then 1 else 0 end) "#www"
from session.unl
;
with u as
(
select case when info is null then '---'
when locate('u=', info) > 0
then substr(info, locate('u=', info)) else '' end u
from session.unl
)
select count(*), u
from u
group by u
;
-- check data from TXBI003 and TXBC021*
-- check all partitions have metaData
with t as
(
select db, ts
from session.unl
group by db, ts
)
, p as
(
select dbName db, tsName ts, partition pa
from sysibm.sysTablePart p join t
on dbName=db and tsName=ts
)
, e as
(
select value(u.db, p.db) db
, value(u.ts, p.ts) ts
, value(u.pa, p.pa) pa
, sta
, substr(err -- more than one unload per part?
-- missing in DB2 catalog?
|| case when p.db is null then ', part notin DB2' else '' end
-- missing in TXBI003? correct stage?
|| case when sta is null then ', part notin TXBI003'
when sta not in ('RW', 'CL', 'DL', 'UL', 'ww')
then ', bad sta in TXBI003'
else '' end
|| case when unl is null and sta not in ('RW', 'CL')
then ', no unl in TXBC021%' else '' end
-- check unl dsn --------
|| case when unl not like 'XB.XB%'
then ', unl not XB.XB% ' else '' end
|| case when locate('.', unl, 4) <> 12
then 'unl db len ' else '' end
|| case when locate('.', unl, 13) not between 14 and 21
then ', unl ts len' else '' end
|| case when locate('.', unl, 13) not between 14 and 21
then ', unl ts len' else '' end
-- is part in DSN correct?
|| case when substr(unl, locate('.', unl, 13), 8)
<> '.P' || right('00000' || u.pa, 5) || '.'
then ', pa dsn=' || substr(unl, locate('.', unl, 13), 8)
else '' end
|| case when p.pa < 1 then ', part<1'
when p.pa > 200 and sta not in ('UL', 'DL')
then ', part>200' else '' end
|| case when p.pa >
case p.db || '.' || left(p.ts, 7)
when 'XBDJC001.SDJC004' then 231 --4 ts, 231 minPa
when 'XBDJC001.SDJC005' then 607 --4 ts, 607 minPa
when 'XBDJC001.SDJC006' then 601 --4 ts, 601 minPa
when 'XBDJC001.SDJC007' then 441 --4 ts, 441 minPa
when 'XBDJC001.SDJC008' then 301 --4 ts, 301 minPa
when 'XBDJC002.SDJC010' then 321 --4 ts, 321 minPa
when 'XBDJC002.SDJC011' then 270 --4 ts, 270 minPa
when 'XBDPM001.SDPM002' then 212 --4 ts, 212 minPa
when 'XBFC4001.SFC4002' then 501 --4 ts, 501 minPa
when 'XBFC4001.SFC4003' then 301 --4 ts, 301 minPa
when 'XBFC4001.SFC4004' then 301 --4 ts, 301 minPa
when 'XBFC4001.SFC4005' then 336 --4 ts, 336 minPa
when 'XBFC4001.SFC4006' then 330 --4 ts, 330 minPa
when 'XBFC4001.SFC4007' then 249 --4 ts, 249 minPa
when 'XBFC4002.SFC4009' then 281 --4 ts, 281 minPa
when 'XBFQY002.SFQY002' then 202 --5 ts, 202 minPa
else 200
end
then ', part >200/aus' else '' end
|| ' ', 2) err
, unl, info
from session.unl u full outer join p
on u.db = p.db and u.ts = p.ts and u.pa = p.pa
)
select * from e
where err <> ''
order by 1, 2, 3
with ur
;
--- tables from DB XB% missing in TXBI003 -----------------------------
select substr(dbName, 1, 8) db
, substr(tsName, 1, 8) ts
, substr(creator, 1, 8) cr
, name tb
from sysibm.sysTables t
where dbName like 'XB%'
and not exists (select 1 from session.unl u
where t.dbName = u.db and t.tsName = u.ts)
order by 1, 2
;
--- www tables --------------------------------------------------------
select db, ts
from session.unl
where sta = 'ww'
group by db, ts
order by 1, 2
;x
--- generate partition exception list --------------------------------
select 'when ''' || dbName || '.' || left(name, 7)
|| ''' then ' || max(partitions)
|| ' -- ' || count(*) || ' ts, ' || min(partitions) || ' minPa'
from sysibm.sysTablespace
where dbName like 'XB%' and partitions > 200
group by dbName, left(name, 7)
order by 1
;
}¢--- A540769.WK.REXX(CONSUMXC) cre=2015-05-22 mod=2015-06-01-13.39.10 A540769 ---
with p as
(
select t.creator cr, t.name tb, t.dbname db, t.tsname ts
, p.partition pa
, value(XC106_DOC_STATE, XC406_PART_STATUS, xr106_DOC_STATE)
stage
, value(XC106_TS_UPDATE, XC406_UPDATE_TS , xr106_TS_UPDATE)
staUpd
, case when XC106_DOC_STATE is not null then 'TXC106A1'
when XC406_PART_STATUS is not null then 'TXC406A1'
when Xr106_doc_state is not null then 'TXR106A1' end
staTb
, u.unl, u.unlTst
, u.pun, u.punTst
, value(u.err, '') unlErr
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC106A1
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(xc106_doc_tabColId, 3, 2)
and xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(xc106_doc_part_no) = p.partition
and xc106_doc_part_no = right('0000' || p.partition, 4)
left join OA1P.TXC406A1
on t.name like 'TXC5%'
and t.name = xc406_table_name
and smallInt(xc406_part_number) = p.partition
and xc406_part_number = right('000' || p.partition, 3)
left join OA1P.Txr106A1
on t.name like 'TXR2%'
and t.name = xr106_doc_tb_name
and smallInt(xr106_doc_part_no) = p.partition
and xr106_doc_part_no = right('000' || p.partition, 3)
left join oa1p.tqz005TecSvUnload u
on t.dbName = u.db and t.tsName = u.ts
and p.partition = u.pa
where (t.dbName = 'XC01A1P'
AND (t.tsName LIKE 'A2%' or t.tsName LIKE 'A5%' ))
or (t.dbName = 'XR01A1P' and t.tsName LIKE 'A2%')
)
/* ?????????
select count(*), count(stage) sta
, sum(case when unl is null then 0 else 1 end) unl
, db, ts
, min(cr) || case when min(cr) = max(cr) then '' else max(cr) end
, min(tb) || case when min(tb) = max(tb) then '' else max(tb) end
, min(statb) || case when min(staTb) = max(staTb)
then '' else max(staTb) end
from p
group by db, ts
????????????? */
, i(c, s, i, clBa, inTx) as
( select 'N', 1, 1, ' ', '' from sysibm.sysDummy1
union all select 'N', 2, 2, ' ', '2 only' from sysibm.sysDummy1
union all select 'Y', 1, 1, 'b', '1 base' from sysibm.sysDummy1
union all select 'Y', 1, 2, 'c', '2 clone' from sysibm.sysDummy1
union all select 'Y', 2, 1, 'c', '1 clone' from sysibm.sysDummy1
union all select 'Y', 2, 2, 'b', '2 base' from sysibm.sysDummy1
)
, l as
(
select p.*
, case when i.i is not null then i.i
else raise_error(70001, 'bad clone ' || s.clone) end inst
, i.inTx
, ( select max(char(c.timestamp) || c.icType || char(c.dsNum))
from sysibm.syscopy c
where p.db = c.dbName and p.ts = c.tsName
and i.i = c.instance
and (p.pa = c.dsNum or c.dsNum = 0)
and ICTYPE IN ('A' ,'C', 'F', 'S', 'W', 'Y')
and not (ICTYPE = 'A' and sType <> 'A') -- part added
) lastFu
, ( select max(char(c.timestamp) || c.icType || char(c.dsNum))
from sysibm.syscopy c
where p.db = c.dbName and p.ts = c.tsName
and i.i = c.instance
and (p.pa = c.dsNum or c.dsNum = 0)
and ICTYPE IN ('A' ,'C', 'F', 'I','R','S','W', 'Y', 'Z')
and not (ICTYPE = 'A' and sType <> 'A') -- part added
) lastInc
from p
join sysibm.sysTablespace s
on p.db = s.dbName and p.ts = s.name
and s.ntables <> 0
left join i on i.c = s.clone and i.s = s.instance
)
, m as
(
select l.*
, substr(lastFu, 27, 1) lastFuTy
, smallint(substr(lastFu, 28)) lastFuPa
, timestamp(substr(lastFu, 1, 26)) lastFuTst
, substr(lastInc, 27, 1) lastIncTy
, smallint(substr(lastInc, 28)) lastIncPa
, timestamp(substr(lastInc, 1, 26)) lastIncTst
from l
)
, ict (iTy, iTx) as
(
select 'A', 'A=addPart' from sysibm.sysDummy1
union all select 'C', 'C=create' from sysibm.sysDummy1
union all select 'F', 'F=fulCopy' from sysibm.sysDummy1
union all select 'I', 'I=incCopy' from sysibm.sysDummy1
union all select 'R', 'R=LoaRpLoYe' from sysibm.sysDummy1
union all select 'S', 'S=LoaRpLoNo' from sysibm.sysDummy1
union all select 'W', 'W=ReorgLoNo' from sysibm.sysDummy1
union all select 'Y', 'Y=LoaRsLoNo' from sysibm.sysDummy1
union all select 'Z', 'Z=LoaRsLoYe' from sysibm.sysDummy1
)
, e2 as
(
select m.*
, value(fu.iTx, lastFuTy) lastFuTx
, value(inc.iTx, lastIncTy) lastIncTx
from m
left join ict fu on fu.iTy = lastFuTy
left join ict inc on inc.iTy = lastIncTy
)
, e as
(
select
case when stage is null then 'part stage missing'
when stage <> 'UL' and unl is not null
then 'unl exists in stage ' || stage
when stage <> 'UL' and (lastFuTy is null
or lastFuTy <> 'F'
or lastFuTst < current timestamp
- 8 days )
then 'no fullCopy in last week'
when stage <> 'UL' then ''
when unl is null or unl = '' then 'unl missing'
when lastIncTy is not null and lastIncTy <> 'F'
and lastIncTst > staUpd
then lastIncTx || 'after unl'
when lastFuTy is not null and lastFuTy <> 'F'
and lastFuTst > staUpd
then lastFuTx || 'after unl'
else ''
end err, e2.*
from e2
)
select substr(db, 1, 8) db
, substr(left(ts, 8) || ' ' || inTx, 1, 16) "ts instanc"
, substr(right(' ' || pa, 5), 1, 5) part
, staUpd, stage
, err
, unlErr
, unlTst, unl
, punTst, pun
, lastFuTx, lastFuPa, lastFuTst
, lastIncTx, lastIncPa, lastIncTst
from e
/* where ty is null or not
((ty = 'F' and tst
> current timestamp - 8 days)
) --??? or (paCre > current timestamp - 24 hours))
*/ order by err || unlErr desc, 1, 2, 3
with ur
;x;
;x;
with p (cr, tb, db, ts, pa, stage, xUpd) as
(
select t.creator, t.name, t.dbname, t.tsname, p.partition
, XC106_DOC_STATE
, XC106_TS_UPDATE
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC106A1 x
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(x.xc106_doc_tabColId, 3, 2)
and x.xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(x.xc106_doc_part_no) = p.partition
and x.xc106_doc_part_no = right('0000' || p.partition, 4)
where t.name = 'TXC200A1'
union all select t.creator, t.name, t.dbname, t.tsname, p.partition
, XC406_PART_STATUS
, XC406_UPDATE_TS
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC406A1 x
on t.name like 'TXC5%'
and t.name = xc406_table_name
and smallInt(x.xc406_part_number) = p.partition
and x.xc406_part_number = right('000' || p.partition, 3)
where t.name like 'TXC5%' and t.name <> 'TXC500A1'
union all select t.creator, t.name, t.dbname, t.tsname, p.partition
, xr106_DOC_STATE
, xr106_TS_UPDATE
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.Txr106A1 x
on t.name like 'TXR2%'
and t.name = xr106_doc_tb_name
and smallInt(x.xr106_doc_part_no) = p.partition
and x.xr106_doc_part_no = right('000' || p.partition, 3)
where t.name like 'TXR2%'
)
select count(*), count(stage), db, ts
, min(cr) || case when min(cr) = max(cr) then '' else max(cr) end
, min(tb) || case when min(tb) = max(tb) then '' else max(tb) end
from p
group by db, ts
;x;
on t.dbName = u.db and t.tsName = u.ts
and p.partition = u.pa
select XC406_TABLE_NAME, MIN(XC406_PART_NUMBER)
, MAX(XC406_PART_NUMBER), COUNT(*)
FROM OA1P.TXC406A1
group by XC406_TABLE_NAME
;x;
with p as
(
select t.creator, t.name, t.dbname, t.tsname
, s.clone, s.instance
, p.partition
, r.copyLastTime, r.copyUpdatedPages, r.copyChanges
, hex(r.copyUpdateLrsn) uLrsn, r.copyUpdateTime
, x.*
, u.*
from sysibm.systables t
join sysibm.sysTableSpace s
on t.dbName = s.dbName and t.tsName = s.name
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join sysibm.sysTableSpaceStats r
on t.dbName = r.dbName and t.tsName = r.name
and p.partition = r.partition
and t.dbid = r.dbid and s.psid = r.psid
left join OA1P.TXC106A1 x
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(x.xc106_doc_tabColId, 3, 2)
and x.xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(x.xc106_doc_part_no) = p.partition
and x.xc106_doc_part_no = right('0000' || p.partition, 4)
left join oa1p.tqz005TecSvUnload u
on t.dbName = u.db and t.tsName = u.ts
and p.partition = u.pa
where t.name = 'TXC200A1'
)
, i(c, s, i, clBa, inTx) as
( select 'N', 1, 1, ' ', '' from sysibm.sysDummy1
union all select 'N', 2, 2, ' ', '2 only' from sysibm.sysDummy1
union all select 'Y', 1, 1, 'b', '1 base' from sysibm.sysDummy1
union all select 'Y', 1, 2, 'c', '2 clone' from sysibm.sysDummy1
union all select 'Y', 2, 1, 'c', '1 clone' from sysibm.sysDummy1
union all select 'Y', 2, 2, 'b', '2 base' from sysibm.sysDummy1
)
, l as
(
select p.*
, case when i.i is not null then i.i
else raise_error(70001, 'bad clone ' || s.clone) end inst
, i.inTx
, ( select max(char(c.timestamp) || c.icType || char(c.dsNum))
from sysibm.syscopy c
where p.db = c.dbName and p.ts = c.tsName
and i.i = c.instance
and (p.pa = c.dsNum or c.dsNum = 0)
) last
from p
join sysibm.sysTablespace s
on p.db = s.dbName and p.ts = s.name
and s.ntables <> 0
join i on i.c = s.clone and i.s = s.instance
)
, m as
(
select l.*
, substr(last, 27, 1) ty
, smallint(substr(last, 28)) dsNum
, timestamp(substr(last, 1, 26)) tst
from l
)
, ict (iTy, iTx) as
(
select 'A', 'A=addPart' from sysibm.sysDummy1
union all select 'C', 'C=create' from sysibm.sysDummy1
union all select 'F', 'F=fulCopy' from sysibm.sysDummy1
union all select 'I', 'I=incCopy' from sysibm.sysDummy1
union all select 'S', 'S=LoaRpLoNo' from sysibm.sysDummy1
union all select 'W', 'W=ReorgLoNo' from sysibm.sysDummy1
union all select 'Y', 'Y=LoaRsLoNo' from sysibm.sysDummy1
)
select substr(db, 1, 8) db
, substr(left(ts, 8) || ' ' || inTx, 1, 16) "ts instanc"
, substr(right(' ' || pa, 5) || right(' ' || dsNum, 5)
, 1, 10) " part dsNu"
, coalesce(iTx, ty) "icType"
, stage
, tst
, m.*
from m
left join ict on iTy = ty
where ty is null or not
((ty = 'F' and tst
> current timestamp - 8 days)
) --??? or (paCre > current timestamp - 24 hours))
order by 1, 2, 3
with ur
;x;
select *
from pa
order by creator, name, partition
;x;
, j as
(
select xc.*, u.unlTst, u.unl, u.puntst, u.pun
, r.copyLastTime, r.copyUpdatedPages, r.copyChanges
, hex(r.copyUpdateLrsn) uLrsn, r.copyUpdateTime
from xc
left join oa1p.tqz005TecSvUnload u
on xc.db = u.db and xc.ts = u.ts
and smallint(xc.xc106_doc_part_no) = u.pa
and xc.xc106_doc_part_no = right('0000' || u.pa, 4)
left join sysibm.sysTableSpaceStats r
on xc.db = r.dbName and xc.ts = r.name
and smallInt(xc.xc106_doc_part_no) = r.partition
and xc.xc106_doc_part_no = right('0000' || r.partition, 4)
and xc.dbid = r.dbid and xc.psid = r.psid
)
select *
from j
order by cr, tb, xc106_doc_part_no
$proc $@=/missFullBase/
$@¢ parse arg , pp dayLim
$=dayLim=- dayLim
$=pp =- if(pp, ', stage')
$!
$/missFullBase/
with xc as
(
select t.creator cr, t.name tb, t.dbname db, t.tsname ts
, t.dbid, s.psId
, x.*
from sysibm.systables t
join sysibm.sysTableSpace s
on t.dbName = s.dbName and t.tsName = s.name
join OA1P.TXC106A1 x
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(x.xc106_doc_tabColId, 3, 2)
and x.xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
)
, j as
(
select xc.*, u.unlTst, u.unl, u.puntst, u.pun
, r.copyLastTime, r.copyUpdatedPages, r.copyChanges
, hex(r.copyUpdateLrsn) uLrsn, r.copyUpdateTime
from xc
left join oa1p.tqz005TecSvUnload u
on xc.db = u.db and xc.ts = u.ts
and smallint(xc.xc106_doc_part_no) = u.pa
and xc.xc106_doc_part_no = right('0000' || u.pa, 4)
left join sysibm.sysTableSpaceStats r
on xc.db = r.dbName and xc.ts = r.name
and smallInt(xc.xc106_doc_part_no) = r.partition
and xc.xc106_doc_part_no = right('0000' || r.partition, 4)
and xc.dbid = r.dbid and xc.psid = r.psid
)
select *
from j
order by cr, tb, xc106_doc_part_no
; xxx
--- temporary explain --------------------------------------------------
set current sqlid = 'A540769';
delete from A540769.plan_table;
delete from A540769.DSN_STATEMNT_TABLE;
delete from A540769.DSN_DetCost_TABLE ;
delete from A540769.dsn_filter_Table ;
delete from A540769.dsn_predicat_table;
explain plan set queryno = 3 for
select * from plan_view1
order by -- collid, progName, version, explain_time,
queryNo, qblockno, planno, mixOpSeq
;
select * from plan_view2
order by -- collid, progName, version, explain_time,
queryNo, qblockno, planno, mixOpSeq
;
select * from plan_view2det
order by -- collid, progName, version, explain_time,
queryNo, qblockno, planno, mixOpSeq
;
select *
from plan_viewPred
order by collid, progName, explain_time,
queryNo, qBlockNo, predNo, orderNo, mixOpSeqNo
with ur
;
rollback
;;;;
SELECT CASE
WHEN XC106_DOC_TABCOLID = 'XC00' THEN 'OA1P00.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC01' THEN 'OA1P01.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC02' THEN 'OA1P02.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC03' THEN 'OA1P03.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC04' THEN 'OA1P04.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC05' THEN 'OA1P05.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC06' THEN 'OA1P06.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC07' THEN 'OA1P07.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC08' THEN 'OA1P08.TXC200A1'
WHEN XC106_DOC_TABCOLID = 'XC09' THEN 'OA1P09.TXC200A1'
END AS XC106_DOC_TABCOLID
, T.* /*
,XC106_DOC_PART_NO
,XC106_DOC_STATE
,XC106_DOC_COUNT
,XC106_DOC_DELCNT
,XC106_DOC_USEDSPAC
,XC106_TS_UPDATE */
FROM OA1P.TXC106A1 T
-- WHERE XC106_DOC_TABCOLID = 'XCNN'
-- AND XC106_DOC_PART_NO = '0001'
ORDER BY XC106_DOC_TABCOLID
,XC106_DOC_PART_NO
WITH UR
}¢--- A540769.WK.REXX(CSM) cre=2016-09-30 mod=2016-09-30-09.58.31 A540769 ------
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
return csmEx2('csmExec' arg(1), arg(2))
/*--- execute a single csmAppc start command
arg(1)=pgm, arg(2)=parm, arg(3)=rest, arg(4)=retOk ------------*/
csmAppc:
appc_rc = 0 /* csmAppc erstellt diese Variable nicht immmer| */
appc_msg.0 = 0
if 0 <> csmEx2('csmAppc start pgm('arg(1)')' ,
copies("parm("quote(arg(2), "'")")",
, arg(2) <> '') arg(3) , arg(4)) then
ggRc = m.tso_rc
else if appc_rc = 0 then
return 0
else do
ggRc = appc_rc
m.csm_err = ''
m.csm_errMsg = 'tso_rc=0'
end
ggMsg = 'csmAppc rc='ggRc 'appc_rc='appc_rc ,
'reason='appc_reason 'state_c='appc_state_c appc_state_f ,
'\n SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ggCsmIx=1 to appc_msg.0
ggMsg = ggMsg '\n ' appc_msg.ggCsmIx
end
m.csm_errMsg = ggMsg'\n'm.csm_errMsg
return ggRc
endRoutine csmAppc
/*--- execute single command in arg(1) -----------------------------*/
csmEx2:
if wordPos(translate(word(arg(1), 2)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if pos('TIMEOUT(' , translate(arg(1))) > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso(arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else if pos('CSMAP47E TP timed out', m.tso_trap) > 0 then
m.csm_err = 'timeout'
else
m.csm_err = ''
m.csm_errMsg = strip('csm' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='m.tso_stmt m.tso_trap ,
'\ntime='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endRoutine csmEx2
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
dd = tsoDD(csmDel, 'a')
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname("dd")", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname("dd")", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName("dd") member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then
return tsoFree(dd)
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call tsoFree dd
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call tsoFree dd
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
say 'please use dsnCopy instead of depreceated csmCopy'
return dsnCopy(fr, to, mbrs)
csmCop2: procedure expose m.
parse upper arg o1 o2, fr, to tA1 ':' tA2, mbrs
frDD = tsoDD('csmFrDD', 'a')
tAt = strip(tA1 firstNS(tA2, ':D'frDD))
toDD = tsoDD('csmToDD', 'a')
mbr1 = abbrev(o2, '&') & words(mbrs) = 1
if mbr1 then do
parse value strip(mbrs) with fMb '>' tMb
call csmAlloc fr'('fMb')', frDD, 'shr'
tM2 = firstNS(tMb, copies(fMb, o2 <> '&-'))
call csmAlloc dsnSetMbr(to, tM2), toDD, 'shr', , tAt
end
else do
call csmAlloc fr, frDD, 'shr'
call csmAlloc to, toDD, 'shr', , tAt
end
if m.tso_recFM.frDD <> m.tso_recFM.toDD ,
| m.tso_lRecL.frDD <> m.tso_lRecL.toDD then do
call tsoFree frDD toDD
return if(m.tso_lRecL.frDD <= m.tso_lRecL.toDD, 'W', 'T')
end
inDD = tsoDD('csmInDD', 'a')
i.0 = 0
if abbrev(o2, '&') & \ mbr1 then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = tsoDD('csmOuDD', 'a')
call dsnAlloc('dd('outDD') new ::V137')
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
isNew = wordPos(disp, 'NEW MOD CAT') > 0
if isNew & nn \== '' then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
recFm = substr(rest, cx+6, 1)
cy = pos(')', rest, cx)
if cy > cx then
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6),
, 0) || substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then
rest = insert('inder', rest, cx+2)
if isNew then
if pos(' BLKSIZE(', ' 'translate(rest)) <= 0 then do
/* without blkSize csm will fail to read for rec < 272 */
cx = pos(' LRECL(', ' 'translate(rest))
lrecl = substr(rest, cx+6,
, max(0, pos(')', rest, cx+6) - cx - 6))
blk = 32760
if datatype(lRecl ,'n') & translate(recfm) = 'F' then
blk = blk - blk // lRecL
rest = rest 'blkSize('blk')'
end
noRetry = retRc <> '' | isNew | nn == ''
alRc = adrCsm('allocate' a1 rest, if(noRetry, retRc, '*'))
m.tso_dsorg.dd = subsys_dsOrg
m.tso_recFM.dd = subsys_recFM
m.tso_blkSize.dd = subsys_blkSize
m.tso_lRecL.dd = subsys_lRecL
if alRc = 0 then
return 0
m.tso_dsnNF.dd = pos('CSMSV29E DATA SET' dsnSetMbr(dsn) ,
'NOT IN CATALOG', m.tso_trap) > 0
if noRetry | \ m.tso_dsnNF.dd then
if pos('*', retRc) > 0 | wordPos(alRc, retRc) > 0 then
return alRc
else
return err(m.csm_errMsg)
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('fUnit2I('b', tracksused.1) ,
|| ',' fUnit2I('b', tracks.1)') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
csmMbrList: procedure expose m.
parse arg m, sys, dsn, msk
/* attention mbrList dataset(....)
does not cleanup proberly if dsn is NOT PO
and much later on follow errors appear
which are hard to debug| */
if dataType(dsnAlloc(sys'/'dsn, , mbrLisDD, 8), 'n') then do
say sys dsn
say m.tso_trap
m.m.dsnNF = m.tso_dsnNF.mbrLisDD
if \ m.m.dsnNF then
call err m.csm_errMsg
m.m.0 = -99
end
else do
m.m.dsnNF = 0
m.m.RECFM = m.tso_RECFM.mbrLisDD
m.m.LRECL = m.tso_LRECL.mbrLisDD
m.m.BLKSIZE = m.tso_BLKSIZE.mbrLisDD
m.m.DSORG = m.tso_DSORG.mbrLisDD
if m.m.DSORG \== 'PO' then
m.m.0 = -98
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
call adrCsm "mbrList ddName(mbrLisDD)" msk ,
"index(' ') short"
m.m.0 = mbr_name.0
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
end
call tsoFree mbrLisDD
end
return m.m.0
endProcedure csmMbrList
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
cmd the tso command to execute
---------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) -------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, cmd, keepTsPrt, retOk
do cx=1 to (length(cmd)-1) % 68 /* split tso cmd in linews */
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmTsPrt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
m.csm_exRxMsg = ''
m.csm_exRxRc = csmappc("csmexec" ,
, "select tsocmd('csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc')", , "*")
if m.csm_exRxRc <> 0 then do /* handle csm error */
call readDD 'rmTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmTsPrt
msg = '\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
do lx=1 to min(100, m.csm_tsPrt.0)
msg = msg'\n'strip(m.csm_tsPrt.lx, 't')
end
l2 = max(lx, m.csm_tsPrt.0-99)
if l2 > lx then
msg = msg'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines' l2 'to' m.csm_tsPrt.0, 79, '-')
do lx=l2 to m.csm_tsPrt.0
msg = msg'\n'strip(m, m.csm_tsPrt.lx, 't')
end
m.csm_exRxMsg = 'cmsExRx rc='ggRc m.csm_errMsg || msg ,
'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call sayNl m.csm_exRxMsg */
end
call tsoFree rmSyPro rmtSys rmtsIn copies(rmTsPrt, keepTsPrt\==1)
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call sayNl m.csm_exRxMsg
else
call err m.csm_exRxMsg
end
return m.csm_exRxRc
endProcedure csmExRx
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmtWsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = firstNS(oOpt, 'v')
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
if o2 == 'p' then do
fo = file('dd(rmTsPrt)')
end
else do
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
end
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec,
, o2 == 'p' , '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH' wSpec,
, o2 == 'p' , '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc,0 4)<1 then call err m.csm_ExRxMsg;",
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/* copy csm end ******************************************************/
}¢--- A540769.WK.REXX(CSMCOPAL) cre=2015-11-20 mod=2015-11-20-09.25.42 A540769 ---
$#@
$@% csmCopyRZ dsn.source.cadb.cdbaMdl(mjbpmdl) $*+
dsn.cadb2 p0.cdbaMdl(mjbpmdl)
$proc $@/csmCopyRZ/
$arg fr t1 t2
call iiIni
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
rzD = iiRz2Dsn(rz)
tt = rz'/'$t1'.'rzD'.'$t2
say 'copying csmCopy' $fr 'to' tt
call csmCopy $fr, tt
end
$/csmCopyRZ/
}¢--- A540769.WK.REXX(CSMCOPY) cre=2012-01-20 mod=2012-01-20-17.12.43 A540769 ---
$#@
$<#/dsn/
A540769.TMPUL.SV03A1P.A033A.PUN
A540769.TMPUL.SV03A1P.A033A.UNL
$/dsn/ $@for v $@¢
call csmCopy 'RZ2/'strip($v), 'RR2/'strip($v)
$!
$#out 20120120 16:59:40
$#out 20120117 16:06:03
}¢--- A540769.WK.REXX(CSMNULL) cre=2014-09-04 mod=2014-09-04-13.16.37 A540769 ---
/* copy csmNull begin **************************************************
pseudo csm Modul, to avoid missing modules error from rexx compiler
***********************************************************************/
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
call err 'csmAlloc not copied into this rexx'
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
call err 'csmLikeAtts not copied into this rexx'
/* copy csmNull end ***************************************************/
}¢--- A540769.WK.REXX(CSMSQL) cre=2012-03-21 mod=2012-03-21-16.30.05 A540769 ---
call sqlIni
call sqldisConnect 'DBAF'
say 'start cmsSql'
sql_HOST = rz8
sql_query = 'select current server cs, current timestamp ts' ,
'from sysibm.sysdummy1'
sql_query = 'select creator, name, createdTs ,current server',
', case when mod(row_number() over(), 2) = 0 then 1 else null end',
'from sysibm.sysTables fetch first 7 rows only'
SQL_DB2SSID = 'DD0G'
sql_PLAN = 'DB2TS'
address tso "CSMAPPC START PGM(CSMASQL)"
say 'csmappc' rc 'sqlCode' sqlCode', sqlD' sqlD', sqlRow#' sqlRow#
call outNl sqlDsnTiarCall(sqlCa)
Do I = 1 To SQL_Message.0
Say SQL_Message.I
End
say _name SQLDA_NAME.0 SQLDA_NAME.1 SQLDA_NAME.2
say rexxName SQLDA_REXXNAME.0 SQLDA_REXXNAME.1 SQLDA_REXXNAME.2
do rx=1 to sqlRow#
t = 'row' rx
say c2x(sqlIndicator.rx)
do cx=1 to sqlD
t = t', da='SQLDA_NAME.1 'rx='SQLDA_REXXNAME.cx
rr = SQLDA_REXXNAME.cx
if substr(sqlIndicator.rx, cx ,1) == 'ff'x then
t = t m.sqlNull
else
t = t value(SQLDA_REXXNAME.cx'.'rx)
end
say t
end
exit
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
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'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
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
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
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 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
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
/*--- 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
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
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)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk, 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
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
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 = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()¢!'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
/* call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
*/ msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(CSRXUTIL) cre=2014-06-03 mod=2014-06-03-10.36.55 A540769 ---
/*------------------------------- REXX ----------------------------*/
/* */
/* Function : Dataset Copy Utility */
/* Mlv : CS159X56 */
/*_________________________________________________________________*/
Parse Source procinfo
procname = Word(procinfo,3)
zerrsm = ""
zerrlm = ""
zerrxm = ""
freedd = ""
Numeric Digits 20
Parse Upper Arg parms
Parse Upper var parms cmd dsnfrom kwto dsnto opt prt
If cmd ^= 'COPY' Then Do
zerrsm = procname':Parameter1 "COPY" missing'
zerrlm = 'Input was:'parms
zerrxm = 'Parm1 was:'cmd
Call SetMsg 'L' 'YES'
End
If dsnfrom = '' Then Do
zerrsm = procname':Parameter2 "System/Vol:Dataset(Member)" missing'
zerrlm = 'Input was:'parms
Call SetMsg 'L' 'YES'
End
If P_Parms(dsnfrom,'()M*') > 0 Then Do
zerrsm = procname ||,
':Parameter2 "System/Vol:Dataset(Member)" was invalid'
zerrlm = 'Input was:'parms
zerrxm = 'Parm2 was:'dsnfrom
Call SetMsg 'L' 'YES'
End
sysf = sys
volf = vol
dsnf = dsn
mbrf = mbr
If kwto ^= 'TO' Then Do
zerrsm = procname':Parameter3 "TO" missing'
zerrlm = 'Input was:'parms
zerrxm = 'Parm3 was:'kwto
Call SetMsg 'L' 'YES'
End
If P_Parms(dsnto,'') > 0 Then Do
zerrsm = procname ||,
':Parameter4 "System/Vol:Dataset(Member)" was invalid'
zerrlm = 'Input was:'parms
zerrxm = 'Parm4 was:'dsnto
Call SetMsg 'L' 'YES'
End
syst = sys
volt = vol
dsnt = dsn
If opt = 'PRINT' & prt = '' Then Do
prt = opt
opt = ''
End
If opt ^= '' & ,
opt ^= 'NOREPLACE' & ,
opt ^= 'REPLACE' & ,
opt ^= 'ZERODIR' Then Do
zerrsm = procname':Parameter5 "NOREPLACE/REPLACE/ZERODIR" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'opt
Call SetMsg 'L' 'YES'
End
If prt ^= '' & ,
prt ^= 'PRINT' Then Do
zerrsm = procname':Parameter6 "PRINT" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'prt
Call SetMsg 'L' 'YES'
End
volp = ''
If volf ^= '' Then ,
volp = "VOLUME("volf") UNIT(SYSALLDA)"
"CSMEXEC ALLOCATE DATASET('"dsnf"') DISP(SHR) SYSTEM('"sysf"')",
volp
If Rc > 0 Then ,
Exit 8
freedd = SUBSYS_DDNAME
ddnf = SUBSYS_DDNAME
devtypxf = Val('SUBSYS_DEVTYPEX')
f1dscbf = Val('SUBSYS_F1DSCB')
dstpf = Val('SUBSYS_RDSNTYPE')
rvolf = Val('SUBSYS_RVOLUMES')
dsorgf = Strip(Val('SUBSYS_DSORG'))
lreclf = Strip(Val('SUBSYS_LRECL'))
blkszf = Strip(Val('SUBSYS_BLKSIZE'))
recfmf = Strip(Val('SUBSYS_RECFM'))
If Substr(dsorgf,1,2) ^= '??' & ,
Substr(dsorgf,1,2) ^= 'PO' & ,
Substr(dsorgf,1,2) ^= 'PS' Then Do
zerrsm = procname':Data set 'dsnf' has an unsupported DSORG: 'dsorgf
zerrlm = 'DSORG must be PS,PSU,PO or POU'
Call SetMsg 'L' 'YES'
End
If f1dscbf = '' Then Do
zerrsm = procname':Data set 'dsnf' must be a DASD dataset'
zerrlm = 'no Format-1-DSCB found on Volume:'rvolf
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) ^= '??' & ,
Substr(dsorgf,1,2) ^= 'PO' & ,
Substr(dsorgf,1,2) ^= 'PS' Then Do
zerrsm = procname':Data set 'dsnf' has an unsupported DSORG: 'dsorgf
zerrlm = 'DSORG must be PS,PSU,PO or POU'
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) = 'PS' & mbrf ^= '' Then Do
zerrsm = procname':Data set 'dsnf' has DSORG: 'dsorgf
zerrlm = 'no member specifiction allowed. Member: 'mbrf
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) = 'PO' & ,
dstpf ^= '40' & ,
dstpf ^= '80' Then Do
zerrsm = procname':Data set 'dsnf' has an invalid DSNTYPE: 'dstpf
zerrlm = 'only PDS (40) or PDSE (80) are supported'
Call SetMsg 'L' 'YES'
End
volp = ''
If volt ^= '' Then ,
volp = "VOLUME("volt") UNIT(SYSALLDA)"
Call Tsoexec "CSMEXEC ALLOCATE DATASET('"dsnt"') ",
" DISP(SHR) SYSTEM('"syst"') "volp,16
new = 0
If rc <> 0 Then Do
msgnc = 'DATA SET ' || dsnt || ' NOT IN CATALOG'
ok = 0
Do i = 1 To ot.0 While ^ok
If Wordpos(Word(ot.i,1),'CSMSV29E IKJ56228I') > 0 | ,
ot.i = msgnc Then ,
ok = 1
End
If ^ok Then Do
Do i = 1 To ot.0 While ^ok
Say ot.i
End
Call Go_Home 12
End
new = 1
End
Else Do
ddnt = SUBSYS_DDNAME
dsorgt = Strip(SUBSYS_DSORG)
If Substr(dsorgt,1,2) ^= '??' & ,
Substr(dsorgt,1,2) ^= 'PO' & ,
Substr(dsorgt,1,2) ^= 'PS' Then Do
zerrsm = procname ||,
':Data set 'dsnt' has an unsupported DSORG: 'dsorgt
zerrlm = 'DSORG must be PS, PSU, PO or POU'
Call SetMsg 'L' 'YES'
End
f1dscbt = Val('SUBSYS_F1DSCB')
If f1dscbt = '' Then Do
new = 1
"FREE F("ddnt")"
End
Else Do
freedd = freedd ddnt
lreclt = Strip(SUBSYS_LRECL)
blkszt = Strip(SUBSYS_BLKSIZE)
recfmt = Strip(SUBSYS_RECFM)
dstpt = SUBSYS_RDSNTYPE
End
End
MBR_MEM# = 1
MBR_DIRA = 0
If Substr(dsorgf,1,2) = 'PO' Then Do
"CSMEXEC MBRLIST DDNAME("ddnf") INDEX(' ') SHORT"
If Rc ^= 0 Then ,
Call Go_Home 12
If opt = '' Then ,
opt = 'NOREPLACE'
End
Else Do
If opt = 'NOREPLACE' | ,
opt = 'ZERODIR' Then Do
zerrsm = procname':Parameter5 "REPLACE/<BLANK>" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'opt
Call SetMsg 'L' 'YES'
End
opt = 'REPLACE'
End
If ^new Then Do
If Substr(dsorgt,1,2) ^= Substr(dsorgf,1,2) Then Do
zerrsm = procname ||,
':DSORG of input must be the same as DSORG of output data set'
zerrlm = 'Input :'Left(dsnf,44)' Dsorg:'dsorgf
zerrxm = 'Output :'Left(dsnt,44)' Dsorg:'dsorgt
Call SetMsg 'L' 'YES'
End
If Substr(dsorgt,1,2) = 'PO' Then Do
If Substr(recfmt,1,1) ^= Substr(recfmf,1,1) Then Do
zerrsm = procname ||,
':RECFM of input must be the same as RECFM of output data set'
zerrlm = 'Input :'Left(dsnf,44)' Recfm:'recfmf
zerrxm = 'Output :'Left(dsnt,44)' Recfm:'recfmt
Call SetMsg 'L' 'YES'
End
If Substr(recfmf,1,1) = 'V' & lreclf > lreclt Then Do
zerrsm = procname ||,
':INVALID LRECL. INPUT LRECL ('lreclf') EXCEEDS',
'OUTPUT LRECL ('lreclt').'
zerrlm = 'Input :'Left(dsnf,44)
zerrxm = 'Output :'Left(dsnt,44)
Call SetMsg 'L' 'YES'
End
End
End
Else Do
Gen_Alloc()
Ac = Rc
If Ac ^= 0 Then Do
Say ccmd
Call Go_Home 12
End
ddnt = SUBSYS_DDNAME
freedd = freedd ddnt
End
csmsysin = SUBSYS_DDNPREF'I'
csmsyspr = SUBSYS_DDNPREF'L'
spc = MBR_MEM#%625 + 1
If mbrf = '' Then ,
mbrf = '*'
If Substr(dsorgf,1,2) = 'PS' | ,
opt ^= 'NOREPLACE' & ,
mbrf = '*' Then Do
Call Tsoexec "ALLOC File("csmsysin") Dummy Reuse",4
End
Else Do
If opt = 'NOREPLACE' Then Do
"CSMEXEC MBRLIST DDNAME("ddnt") INDEX('.2') SHORT"
If Rc ^= 0 Then ,
Call Go_Home 12
End
Call Tsoexec "ALLOC File("csmsysin") New Space("spc" 1) Tracks",
" Lrecl(80) Recfm(F B) Reuse Dsorg(PS) ",
" Blksize(0)",4
found = 0
n = 0
ttrmem. = ''
Do i = 1 To MBR_NAME.0
mbr = Strip(MBR_NAME.i)
ttr = MBR_TTRP.i
If Bitand(X2c(MBR_INDC.i),'80'X) ^= '80'X Then Do
If Pat_Match(mbrf,mbr) Then Do
found = 1
If opt ^= 'NOREPLACE' | ,
MBR_NDX.2.mbr = 0 Then Do
n = n + 1
mbr.n = mbr
ttr.n = MBR_TTRP.i
End
End
End
Else Do
ttrmem.ttr = ttrmem.ttr mbr
End
End
If n = 0 Then Do
If found then ,
zerrsm = procname':Member:'mbrf' not replaced'
else ,
zerrsm = procname':Member:'mbrf' not found'
Call SetMsg 'N' 'YES'
Call Go_Home 4
End
k = 0
Do i = 1 To n
k = k + 1
O.k = ' S M='mbr.I
ttr = ttr.i
ttrmem = ttrmem.ttr
Do j = 1 To Words(ttrmem)
k = k + 1
O.k = ' S M='Word(ttrmem,j)
End
End
Call Tsoexec "Execio "k" Diskw "csmsysin" (Stem O. Finis)",4
End
freedd = freedd csmsysin
/* spc = spc * 3 */
Call Tsoexec "ALLOC File("csmsyspr") New Space("spc" 5) Cylinder",
" Lrecl(137) Recfm(V B) Reuse Dsorg(PS) ",
" Blksize(32760)",4
freedd = freedd csmsyspr
cmdu = 'CSMUTIL CSM,COPY'opt',DD(,,,,'csmsysin',' ||,
csmsyspr',,'||,
ddnf',' ||,
ddnt'),MARC(0)'
x = Outtrap('Ot.',,'NOCONCAT')
ot.0 = 0
cmdu
uc = Rc
x = Outtrap('OFF')
msg. = ''
If uc ^= 0 | prt = 'PRINT' Then Do
Call Tsoexec "Execio * Diskr "csmsyspr" (Stem msg. Finis)",4
Do i = 1 To ot.0
Say ot.i
End
Do i = 1 To Msg.0
Say msg.i
End
End
Call Go_Home uc
Exit
/* --------------------------------------------------------------------
Procedure Go_Home
----------------------------------------------------------------- */
Go_Home:
If freedd ^= '' Then ,
"FREE F("freedd")"
Exit Arg(1)
/* --------------------------------------------------------------------
Procedure Gen_Alloc
----------------------------------------------------------------- */
Gen_Alloc:
unitc = Length(rvolf)%6
ds1Lsta = Substr(f1dscbf,109,6)
spcb = X2c(Substr(f1dscbf,101,2))
ext2spc = X2d(Substr(f1dscbf,103,6))
spcround = 1
spcunit = ''
avgrec = ''
Select
When Bitand(Spcb,'10'X) = '10'X Then Do
spcx = X2c(Substr(f1dscbf,71,2))
secspace = X2d(Substr(f1dscbf,73,4))
Select
When Bitand(spcx,'08'X) = '08'X Then ,
secspace = secspace * 256
When Bitand(spcx,'04'X) = '04'X Then ,
secspace = secspace * 65536
Otherwise Nop
End
Select
When Bitand(spcx,'80'X) = '80'X Then Do
spcunit = 'BLOCKS('blkszf')'
spcround = blkszf
End
When Bitand(spcx,'40'X) = '40'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'M'
ext2spc = Secspace
spcround = 1000000
End
When Bitand(spcx,'20'X) = '20'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'K'
ext2spc = secspace
spcround = 1000
End
When Bitand(spcx,'10'X) = '10'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'U'
ext2spc = secspace
spcround = 1
End
Otherwise Nop
End
End
When Bitand(spcb,'C0'X) = 'C0'X Then Do
spcunit = 'CYLINDER'
End
When Bitand(spcb,'80'X) = '80'X Then Do
spcunit = 'TRACKS'
End
When Bitand(spcb,'40'X) = '40'X Then Do
spcunit = 'BLOCKS('blkszf')'
spcround = blkszf
End
Otherwise Do
spcunit = '?'
End
End
ext1spc = 0
k64 = 2**16
If Substr(f1dscbf,123,2) ^= '00' Then Do
c1 = X2d(Substr(f1dscbf,127,4))+,
(X2d(Substr(f1dscbf,131,3))*k64)
t1 = X2d(Substr(f1dscbf,134,1))
c2 = X2d(Substr(f1dscbf,135,4))+,
(X2d(Substr(f1dscbf,139,3))*k64)
t2 = X2d(Substr(f1dscbf,142,1))
ext1spc = ((c2*15+t2)-(c1*15+t1))+1
End
Select
When Substr(spcunit,1,3) = 'TRA' Then Nop
When Substr(spcunit,1,3) = 'CYL' Then ,
ext1spc = ext1spc % 15
Otherwise Do
If blkszf = 0 Then Do
spcunit = 'TRACKS'
avgrec = ''
End
Else Do
"CSMEXEC TRKCAL "Substr(devtypxf,7,2),
D2x(ext1spc,8),
D2x(MBR_DIRA,8),
D2x(blkszf,4),
ds1Lsta
If Rc = 0 Then ,
ext1spc = (SUBSYS_BYTESALC)%spcround
End
End
End
ccmd = "CSMEXEC ALLOCATE DATASET('"dsnt"')",
"DISP(CAT)",
"SYSTEM("syst")",
"RECFM("recfmf") "spcunit
If unitc > 1 Then ,
ccmd = ccmd" UNITCNT("unitc")"
If volt ^= '' Then ,
ccmd = ccmd" VOLUME("volt")"
ccmd = ccmd" BLKSIZE("blkszf")"
ccmd = ccmd" LRECL("lreclf")"
ccmd = ccmd" DSORG("dsorgf")"
If Substr(dsorgf,1,2) = 'PO' Then Do
If dstpf = '40' Then ,
ccmd = ccmd" DSNTYPE(PDS)"
If dstpf = '80' Then Do
ccmd = ccmd" DSNTYPE(LIBRARY)"
MBR_DIRA = 0
End
End
If avgrec ^= '' Then ,
ccmd = ccmd" AVGREC("avgrec")"
dir = ''
If MBR_DIRA > 0 Then ,
dir = ','MBR_DIRA
ccmd = ccmd" SPACE("ext1spc','ext2spc || dir")"
Return ccmd
/* --------------------------------------------------------------------
Procedure SetMsg:
----------------------------------------------------------------- */
SetMsg:
Parse Arg MsgOpt .
If zerrsm ^= '' Then ,
Say zerrSm
If zerrlm ^= '' Then ,
Say zerrlm
If zerrxm ^= '' Then ,
Say zerrxm
If msgopt = 'L' Then ,
Call Go_Home 12
zerrsm = ""
zerrlm = ""
zerrxm = ""
Return
Val:
If Wordpos(Arg(1),SUBSYS_VNAMES) > 0 Then ,
Return Value(Arg(1))
Else ,
Return ''
P_Parms:Procedure Expose sys dsn vol mbr
Zprefix= Sysvar('SYSPREF')
svdm = Arg(1)
sys = ''
vol = ''
mbr = ''
dsn = ''
zerrxm = ''
Select
When Pos('/',svdm) = 0 &,
Pos(':',svdm) = 0 Then ,
Parse Upper Var svdm dsn .
When Pos('/',svdm) = 0 &,
Pos(':',svdm) > 0 Then ,
Parse Upper Var svdm vol':'dsn .
When Pos('/',svdm) > 0 &,
Pos(':',svdm) > 0 Then ,
Parse Upper Var svdm sys'/'vol':'dsn .
Otherwise ,
Parse Upper Var svdm sys'/'dsn .
End
If sys = '*' | ,
sys = '' Then ,
sys = Mvsvar('SYSNAME')
If sys ^= '' Then Do
res = VerifySystemName(sys,' ')
Parse Var res frc zerrsm zerrlm
If frc = 8 Then Do
zerrsm = zerrsm' . Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
End
trail = ''
If Pos('(',dsn) > 0 Then Do
Parse Var dsn dsnx'('mbr')'trail
If trail ^= '' & trail ^= "'" Then Do
zerrsm = 'invalid dsname'
zerrlm = 'Data set name:'dsn' is invalid'
Call SetMsg 'I' 'YES'
Return 8
End
dsn = dsnx
End
If dsn = '' Then Do
zerrsm = 'dsname missing'
zerrlm = 'Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
qu = ""
If Substr(dsn,1,1) = "'" Then ,
qu = "'"
dsn = Strip(dsn,,"'")
If mbr ^= '' Then ,
cdsn = qu || dsn"("mbr")" || qu
Else ,
cdsn = qu || dsn || qu
res = DsnCheck(cdsn,Arg(2)"''",zprefix)
Parse Var res frc dsn mbr
If Frc = 8 Then Do
Parse Var res frc zerrsm zerrlm
zerrsm = zerrsm' . Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
/*
say 'system:'sys
say 'vol :'vol
say 'dsn :'dsn
say 'member:'mbr
*/
Return 0
/* $INCLUDE IRPVERSN */
/* $START IRPVERSN */
/* ------------------------------------------------------------------ *
* Procedure VerifySystemName: *
* Rc = 0 ===> Ok *
* ^= 0 ===> invalid *
* ------------------------------------------------------------------ */
VerifySystemName:Procedure
Rmtsys = Strip(Arg(1))
If Arg(2) = '' & Rmtsys = '' Then ,
Return 0
If Rmtsys = '*' Then ,
Return 0
Sc = '0'
Do I = 1 To Length(Rmtsys)
Mask = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ#$@0123456789' || Sc
If Pos(Substr(Rmtsys,I,1),Mask) = 0 Then Do
Sm = 'invalid_System_Name'
Lm = 'at Position 'I'. Valid Characters: 'mask
Return 8 Sm Lm
End
Sc = '_'
End
Return 0
/* --------------------------------------------------------------------
End, VerifySystemName
----------------------------------------------------------------- */
/* $END IRPVERSN */
/* $INCLUDE IRPTSOEX */
/* $START IRPTSOEX */
/* --------------------------------------------------------------------
Procedure Tsoexec: Execute TSO Commands
----------------------------------------------------------------- */
Tsoexec:
x = Outtrap('Ot.',,'NOCONCAT')
Address Tso Arg(1)
Lc = Rc
x = Outtrap('OFF')
If Lc > Arg(2) | Lc < 0 & Arg(2) ^= 99 Then Do
Say Copies('*',79)
Say 'Rc('Lc') executing "'Arg(1)'" at Line 'Sigl ,
'in Procedure 'Procname
Do II = 1 To Ot.0
Say Ot.II
End
Say Copies('*',79)
Call Go_Home Lc
End
Return
/* --------------------------------------------------------------------
End, Tsoexec
----------------------------------------------------------------- */
/* $END IRPTSOEX */
/* $INCLUDE IRPVERDS */
/* $START IRPVERDS */
/* ------------------------------------------------------------------ *
* Procedure DsnCheck: Dsname, Options, Prefix *
* Options: ) ==> add missing ) *
* ( ==> allow Member or Gdg *
* G ==> allow Gdg *
* + ==> allow Gdg +1 *
* - ==> allow Gdg -n *
* 0 ==> allow Gdg 0 *
* M ==> allow Member *
* * ==> allow generic Membername *
* ' ==> allow quoted Dsname *
* '' ==> allow quoted Dsname, add *
* Rc = 0 ===> Dsname missing quote *
* 1 ===> Dsname(Member) *
* 2 ===> Dsname(*Member%) *
* 3 ===> Dsname(Gdg) *
* 8 ===> Error *
* ------------------------------------------------------------------ */
DsnCheck:Procedure Expose Dsnqual.
Dsnqual. = ''
Dsnqual.0= 0
Dsn = Translate(Arg(1))
Ldsn = Length(Dsn)
Dsn1 = Dsn
If Dsn = '' Then
Return '8 missing_Dsname'
If Pos(' ',Dsn) > 0 Then
Return '8 invalid_Dsname (contains one or more Blanks) Dsn:'Dsn
If Pos("'",Arg(2)) > 0 Then Do
If Substr(Dsn,1,1) = "'" Then Do
If Ldsn = 1 Then ,
Return '8 invalid_Dsname (ending quote missing) Dsn:'Dsn
If Substr(Dsn,Ldsn,1) <> "'" Then Do
If Pos("''",Arg(2)) > 0 Then Do
Ldsn = Ldsn + 1
Dsn = Dsn"'"
End
Else ,
Return '8 invalid_Dsname (ending quote missing) Dsn:'Dsn
End
If Ldsn = 2 Then ,
Return '8 missing_Dsname Dsn:'Dsn
Dsn1 = Substr(Dsn,2,Ldsn-2)
End
Else Do
If Arg(3) <> '' Then ,
Dsn1 = Arg(3)'.'Dsn1
End
End
Else Do
If Pos("'",Dsn) > 0 Then
Return '8 invalid_Dsname (no quotes allowed) Dsn:'Dsn
End
Mbr = ''
Ldsn = Length(Dsn1)
Cp = Pos("(",Dsn1)
If Cp > 0 Then Do
If Pos("(",Arg(2)) = 0 Then ,
Return '8 invalid_Dsname (member not allowed) Dsn:'Dsn
Mbr = Substr(Dsn1,Cp+1)
Lmbr = Length(Mbr)
If Lmbr= 0 Then
Return '8 missing_Member/GDG Dsn:'Dsn
If Substr(Mbr,Lmbr,1) <> ")" & ,
Pos(")",Arg(2)) > 0 Then Do
Mbr = Mbr')'
Lmbr = Lmbr + 1
End
If Lmbr <= 1 Then ,
Return '8 invalid_Member/GDG (Member or ending ")"',
'missing) Dsn:'Dsn
Dsn1 = Substr(Dsn1,1,Cp-1)
Ldsn = Cp-1
If Substr(Mbr,Lmbr,1) <> ")" Then ,
Return '8 invalid_Member (ending ")" missing) Dsn:'Dsn
Mbr = Substr(Mbr,1,Lmbr-1)
Lmbr = Lmbr - 1
If Lmbr = 0 Then ,
Return '8 missing_Member/GDG Dsn:'Dsn
If Lmbr > 8 Then ,
Return '8 invalid_Member/GDG (more than 8 bytes) Dsn:'Dsn
End
If Ldsn = 0 Then ,
Return '8 missing_Dsname Dsn:'Dsn
If Ldsn > 44 Then ,
Return '8 invalid_Dsname (more than 44 Bytes) Dsn:'Dsn1
If Substr(Dsn1,1,1) = '.' | ,
Substr(Dsn1,Ldsn,1) = '.' Then ,
Return '8 invalid_Dsname (.) Dsn:'Dsn1
Dsn2 = Translate(Dsn1,' ','.')
Dsnqual.0 = Words(Dsn2)
Chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ#$@'
Do I = 1 To DsnQual.0
Dsnqual.I = Word(Dsn2,I)
If Length(DsnQual.I) > 8 Then ,
Return '8 invalid_Dsname ('I'.Qualifier > 8) Dsn:'Dsn1
Okc = Chars
Do J = 1 To Length(DsnQual.I)
C = Substr(DsnQual.I,J,1)
If Pos(C,Okc) = 0 Then ,
Return '8 invalid_Dsname (Invalid ',
'Char.:"'C'" found) Dsn:'Dsn1
Okc = Chars'01234567890-'
End
End
Okm = ''
Frc = 0
If Pos("*",Mbr) > 0 | ,
Pos("%",Mbr) > 0 Then Do
If Pos("*",Arg(2)) = 0 Then ,
Return '8 invalid_Member (no generic Member allowed) Dsn:'Dsn
Frc = 2
Okm = '*%'
End
C1 = Substr(Mbr,1,1)
If Pos(C1,"+-0") > 0 Then Do
If Pos("G",Arg(2)) = 0 Then ,
Return '8 invalid_Member ',
'(no gdg specification allowed) Dsn:'Dsn
If Pos(C1,Arg(2)) = 0 Then ,
Return '8 invalid_Gdg ',
'(no gdg with "'C1'" allowed) Dsn:'Dsn
If Mbr <> '0' Then Do
If Datatype(Substr(Mbr,2)) <> 'NUM' Then ,
Return '8 invalid_Gdg_Spec. ',
'(numeric value expected) Dsn:'Dsn
End
If C1 = '-' & Mbr = '0' Then Do
Return '8 invalid_Gdg_Spec. ',
'(-0 not allowed) Dsn:'Dsn
End
If C1 = '+' & Mbr <> '+1' Then Do
Return '8 invalid_Gdg_Spec. ',
'(only +1 allowed) Dsn:'Dsn
End
Return 3 Dsn1 Mbr
End
If Pos("M",Arg(2)) = 0 & Length(Mbr) > 0 Then ,
Return '8 Member_invalid ',
'(only gdg specification allowed) Dsn:'Dsn
Okc = Chars || Okm
Do J = 1 To Length(Mbr)
C = Substr(Mbr,J,1)
If Pos(C,Okc) = 0 Then ,
Return '8 invalid_Member (Invalid ',
'Char.:"'C'" found) Dsn:'Dsn
Okc = Chars'01234567890-'Okm
Frc = 1
End
Return Frc Dsn1 Mbr
/* --------------------------------------------------------------------
End, Dsn_Check
----------------------------------------------------------------- */
/* $END IRPVERDS */
/* $INCLUDE IRPPATTM */
/* $START IRPPATTM */
/* --------------------------------------------------------------------
Procedure Pat_Match Check Pattern
----------------------------------------------------------------- */
Pat_Match:Procedure
Pat = Arg(1)
P = Pos('**',Pat)
Do While P>0
Pat = Substr(Pat,1,P-1)Substr(Pat,P+1)
P = Pos('**',Pat)
End
Patl= Length(Pat)
Str = Arg(2)
Strl= Length(Str)
If Patl = 0 Then Do
If Strl = 0 Then ,
Return 1
Return 0
End
If Pat == '*' Then ,
Return 1
If Strl = 0 Then ,
Return 0
Patc = Substr(Pat,1,1)
If Patc = '*' Then Do
Do I = 1 To Strl
If Pat_Match(Substr(Pat,2),Substr(Str,I)) Then ,
Return 1
End
End
Else Do
If Patc = '%' | ,
Patc = Substr(Str,1,1) Then ,
Return Pat_Match(Substr(Pat,2),Substr(Str,2))
End
Return 0
/* --------------------------------------------------------------------
End, Pat_Match
----------------------------------------------------------------- */
/* $END IRPPATTM */
}¢--- A540769.WK.REXX(CSV) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ------
/* copy csv begin ****************************************************/
/**** csvRdr reads a text file, in csv format
and creates a class from column head in first line
csvRdr#jRead returns the create objects ************************/
csv2ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv2ObjRdr', 'm.m.opt = arg2' ,
, 'call csv2ObjBegin m' ,
, 'call csv2Obj m, rStem, $i'), rdr, opt)
csv2ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return m
endProcedure csvRdrOpenFinish
csv2Obj: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(translate(li, ' ', ','), 1))
call mAdd wStem, csv2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csv2Obj
/*--- convert csv line into object of class cl ----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
/*--- clear remaining fields and stems and mutate -------------------*/
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/**** csvWordRdr: similar to csvRdr, but input line format
are quoted or unquoted words ****************************/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvWordRdr', 'm.m.opt = arg2' ,
, 'call csvWordBegin m' ,
, 'call csvWord m, rStem, $i'), rdr, opt)
csvWordBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvWord: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(li, 1))
call mAdd wStem, csvWord2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csvWord
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWord2O
/**** csvColRdr: similar to csvRdr, but input format
are fixed width columns *********************************/
/*--- create object for fixLenColumns format ------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvColRdr', 'm.m.opt = arg2' ,
, 'call csvColBegin m' ,
, 'call csvCol m, rStem, $i'), rdr, opt)
csvColBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvCol: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then do
s = scanSrc(csv_colOpen, li)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
end
call mAdd wStem, csvCol2O(m, mNew(m.m.class), m.m.class, li)
return
endProcedure csvCol
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- csv4obj add a header line
and objects of the same class in csv format ---------------*/
csv4ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv4ObjRdr', ,
, 'call csv4ObjBegin m' ,
, 'call csv4Obj m, rStem, $i'), rdr, opt)
csv4ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
endProcedure csv4ObjBegin
csv4Obj: procedure expose m.
parse arg m, wStem, o
if o == '' then do
if m.m.class \== '' then
call mAdd wStem, ''
return
end
cl = objClass(o)
if cl \== m.m.class then do
if m.m.class \== '' then
return err('class('o')='cl '<>' m.m.class)
m.m.class = cl
ff = classMet(cl, 'oFlds')
if m.ff.0 < 1 then
return err('no fields in' cl)
t = ''
do fx=1 to m.ff.0
t = t','m.ff.fx
end
call mAdd wStem, substr(t, 2)
m.m.oFldD = classMet(cl, 'oFldD')
end
call mAdd wStem, csv4O(o, m.m.oFldD, 0)
return
endProcedure csv4Obj
/*--- return the csv string for an object ---------------------------*/
csv4o: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 == oNull then
res = res','
else if pos(',', v1) > 0 | pos('"', v1) > 0 | v1 == '' then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4o
/*--- fill empty fieldds with value of previous row -----------------*/
csvE2PrevRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvE2PrevRdr', 'm.m.opt = arg2' ,
, "m.m.prev = ''" ,
, 'call csvE2Prev m, rStem, $i'), rdr, opt)
/*--- externalize o and add to wStem --------------------------------*/
csvE2Prev: procedure expose m.
parse arg m, wStem, o
if o == '' then
return
ff = oFldD(o)
hasData = 0
do fx=1 to m.ff.0
f1 = o || m.ff.fx
if m.f1 \== '' then do
hasData = 1
iterate
end
if m.m.prev == '' then
iterate
p1 = m.m.prev || m.ff.fx
m.f1 = m.p1
end
if \ hasData then
return
call mAdd wStem, o
m.m.prev = o
return
endProcedure csvE2Prev
csvColBegin: procedure expose m.
/**** csvExt externalises object into csvExt format
including object cycles and classes
csv+ protocoll, first field contains meta info ---------------------
v,text null or string
w,text w-string
c name classAdr,flds class definition
b name classAdr, class forward declaration
m name adr,text method
o classAdr adr,flds object definition and output
d classAdr adr,flds object definition wihtout output
f classAdr adr, object forward declaration
r adr, reference = output of already defined objects
* text unchanged text including ' " ...
* flds csv flds
**********************************************************************/
csvExtRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvExtRdr', ,
, 'call csvExtBegin m',
, 'call csvExt m, rStem, $i'), rdr, opt)
csvExtBegin: procedure expose m.
parse arg m
d = m'.DONE'
call mapReset d, 'K'
call mapPut d, m.class_class, 'class'
call mapPut d, m.class_v, 'v'
call mapPut d, m.class_w, 'w'
call mapPut d, m.class_o, 'o'
return m
endProcedure csvExtBegin
/*--- externalize o and add to wStem --------------------------------*/
csvExt: procedure expose m.
parse arg m, wStem, o
c = objClass(o)
if c == m.class_W then
return mAdd(wStem, 'w,'substr(o, 2))
if oKindOfString(o) then
return mAdd(wStem, 'v,'o)
if c == m.class_class then
call csvExtClass m, wStem, o
if m.m.done.o == 0 then do
m.m.done.o = 1
call mAdd wStem, 'f' csvExtClass(m, wStem, c) o','
end
if symbol('m.m.done.o') == 'VAR' then
return mAdd(wStem, 'r' o',')
return mAdd(wStem, 'o' c o || csvExtObjTx(m, wStem, o))
endProcedure csvExt
csvExtObjTx: procedure expose m.
parse arg m, wStem, o
call mapAdd m'.DONE', o, 0
c = objClass(o)
if c \== m.class_class & pos(m.m.done.c, 12) < 1 then
call csvExtClass m, wStem, c
ff = classMet(c, 'oFldD')
r = ''
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then do
v1 = s2o(v1)
end
else if \ (c2 == m.class_N | c2 == m.class_W) then do
if m.m.done.v1 == 0 then do
m.m.done.v1 = 1
call mAdd wStem, 'f' c2 v1','
end
if symbol('m.m.done.v1') \== 'VAR' then
call mAdd wStem, 'd' c2 v1 ,
|| csvExtObjTx(m, wStem, v1)
end
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
m.m.done.o = 2
return r
endProcedure csvExtObjTx
csvExtClass: procedure expose m.
parse arg m, wStem, c
res = mapGet(m'.DONE', c, '-')
if res == 0 then do
m.m.done.c = 1
call mAdd wStem, 'b' if(m.c.name == '', '-', m.c.name) c','
return c
end
if res == 1 then
return c
if res \== '-' then
return res
call mapAdd m'.DONE', c, 0
ty = m.c
res = if(m.c.name == '', '-', m.c.name) c
if ty == 'u' then do
res = 'c' res',u'
if m.c.0 > 0 then do
r = ''
do cx=1 to m.c.0
r = r','csvExtClassEx(m, wStem, m.c.cx)
end
res = res substr(r, 2)
end
end
else if ty == 'm' & m.c.0 == 0 then
res = 'm' res','m.c.met
else
res = 'c' res','csvExtClassEx(m, wStem, c)
call mAdd wStem, res
call mapPut m'.DONE', c, c
return c
endProcedure csvExtClass
csvExtClassEx: procedure expose m.
parse arg m, wStem, c
res = ''
ch = c
do forever
g = mapGet(m'.DONE', c, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res csvExtClass(m, wStem, ch))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('csvExtClassEx bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure csvExtClassEx
/*--- convert variable len recs to fixLen
& = continuation, | end (to protect ' &|') -------------------*/
csvV2FRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvV2FRdr', 'm.m.maxLen = arg2',
, 'call csvV2FBegin m, m.m.maxLen',
, 'call csvV2F m, rStem, $i'), rdr, arg)
csvV2FBegin: procedure expose m.
parse arg m, maxL
m.m.maxLen = word(maxL 55e55, 1)
return m
endProcedure csvV2FBegin
csvV2F: procedure expose m.
parse arg m, wStem, line
if line \== '' & pos(right(line, 1), ' &|') > 0 then
line = line'|'
if length(line) <= m.m.maxLen then
return mAdd(wStem, line)
do cx=1 by m.m.maxLen-1 to length(line)-m.m.maxLen
call mAdd wStem, substr(line, cx, m.m.maxLen-1)'&'
end
return mAdd(wStem, substr(line, cx))
endProcedure csvV2F
/*--- f2v fixLen to variable len lines: &=continuation |=endMark ----*/
csvF2VRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvF2VRdr', ,
, 'call csvF2VBegin m' ,
, 'call csvF2V m, rStem, $i' ,
, 'call csvF2VEnd m'), rdr, arg)
csvF2VBegin: procedure expose m.
parse arg m
m.m.strt = ''
return m
endProcedure csvF2VBegin
csvF2V: procedure expose m.
parse arg m, wStem, aLi
li = strip(aLi, 't')
if right(li, 1) == '&' then do
m.m.strt = m.m.strt || left(li, length(li) - 1)
return
end
if right(li, 1) == '|' then
call mAdd wStem, m.m.strt || left(li, length(li) - 1)
else
call mAdd wStem, m.m.strt || li
m.m.strt = ''
return
endProcedure csvF2V
csvF2VEnd: procedure expose m.
parse arg m
if m.m.strt \== '' then
return err("csvF2vEnd but strt='"m.m.strt"'")
return m
endProcedure csvF2VEnd
/*--- internalize objects in ext format -----------------------------*/
csvIntRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvIntRdr', ,
, 'call csvIntBegin m',
, 'call csvInt m, rStem, $i'), rdr, opt)
csvIntBegin: procedure expose m.
parse arg m
m.m.forward = ''
d = m'.DONE'
call mapReset d, 'K'
return
endProcedure csvIntBegin
csvInt: procedure expose m.
parse arg m, wStem, line
parse var line hd ',' rest
parse var hd h1 h2 h3 hr
d = m'.DONE'
if pos(h1, 'vwr') > 0 then do
if m.m.forward \== '' then
return err('csvInt: forward='m.m.forward 'not empty:' line)
if h1 == 'v' & h2 == '' then
return mAdd(wStem, rest)
if h1 == 'w' & h2 == '' then
return mAdd(wStem, m.o_escW || rest)
if h1 \== 'r' | h2 == '' | h3 \== '' | rest \== '' then
return err('csvInt: bad line' line)
r = mapGet(d, h2, '')
if r == '' then
return err('csvInt: undefined reference' line)
return mAdd(wStem, r)
end
if h3=='' | hr\=='' | length(h1)\==1 | pos(h1, 'bcmdfo') < 1 then
return err('csvInt: bad line' line)
if h1 == 'b' | h1 == 'f' then do
if symbol('m.d.h3') == 'VAR' then
return err('csvInt: forward already defined:' line)
if h1 == 'b' then do
if h2 == '-' then
h2 = 'CsvForward'
n = classNew('n' h2 || (m.class.0+1) 'u')
m.n.met = h2'*'
end
else do
cl = mapGet(d, h2, '')
if cl == '' then
return err('csvInt: undefined class:' line)
n = mNew(cl)
end
call mapAdd d, h3, n
m.m.forward = m.m.forward h3
return
end
if h1 == 'm' then do
n = classNew('m' h2 rest)
return mapAdd(d, h3, n)
end
if h1 == 'c' then do
rx = 1
rr = ''
do while rx <= length(rest)
ry = pos(',', rest, rx+1)
if ry < 1 then
ry = length(rest)+1
r1 = substr(rest, rx, ry-rx)
rI = wordIndex(r1, words(r1))
if rI == 1 & abbrev(r1, ',') then
rI = 2
rL = strip(substr(r1, rI))
if length(rL) \== 1 | pos(rL, 'vwor') < 1 then do
rL = mapGet(d, rL, '')
if rL == '' then
return err('csvInt undef class' rL 'line:' line)
end
rr = rr || left(r1, rI-1)rL
rx = ry
end
end
fx = wordPos(h3, m.m.forward)
if fx > 0 then do
m.m.forward = strip(delWord(m.m.forward, fx, 1))
n = mapGet(d, h3)
if h1 == 'c' then do
call classNew 'n=' m.n.name rr
call classMet n, 'new'
return
end
cl = 'CLASS'substr(n, 2, pos('.', n, 3)-2)
if cl \== mapGet(d, h2) then
return err('csvInt: forward class' cl 'mismatches' line)
end
else do
if mapHasKey(m, d, h3) then
return err('already defined:' line)
if h1 == 'c' then do
do while datatype(right(h2, 1), 'n')
h2 = left(h2, length(h2)-1)
end
if h2 == '-' then
h2 = 'CsvForward'
s = ''
cl = classNew(copies('n*' h2' ', h2 \== '-')rr)
call classMet cl, 'new'
return mapAdd(d, h3, cl)
end
cl = mapGet(d, h2, '')
if cl == '' then
return err('undefined class:' line)
n = mNew(cl)
call mapAdd d, h3, n
end
call csv2o n, cl, rest
ff = classFldD(cl)
do fx=1 to m.ff.0
f1 = n || m.ff.fx
c1 = m.ff.fx.class
if m.c1 \== 'r' | m.f1 == '' | abbrev(m.f1, m.o_escW) then
iterate
t1 = mapGet(d, m.f1, '')
if t1 == '' then
return err('missing reference' fx m.f1 'in' line)
m.f1 = t1
end
if h1 == 'o' then do
if m.m.forward \== '' then
call err 'forward not empty:' line
call mAdd wStem, n
end
return
endProcedure csvInt
/* copy csv end ****************************************************/
}¢--- A540769.WK.REXX(DBACHECK) cre=2009-06-09 mod=2012-11-26-17.12.39 A540769 ---
/* rexx ****************************************************************
synopsis: DBACHECK v1.0
edit macro to enforce CS defaults for DB2:
createTablespace createIndex
stoGroup GSMS stoGroup GSMS
priQty -1 priQty -1
secQty -1 secQty -1
compress YES copy NO
segSize 64 falls |0 falls nicht part or LOB
dssize 16G falls partitioniert
large entfernen
lockmax SYSTEM falls 0 oder lockSize
************************************************************************
26.11.2011 w. keller fix add segsize 0 if not segmented (not 64|||)
end of help */ /*
27.08.2011 w. keller segSize 0 erlauben und nicht ändern
24.06.2011 w. keller lockmax abhängig von lockSize
22.06.2011 w. keller neue copies
1.09.2010 w. keller support index on auxilary table without columns
8.06.2010 w. keller dsSize 16GB
11.02.2010 w. keller EX0 für exit 0, damit's keinen macro fehler gibt
18.01.2010 w. keller tentative: allow $ in sql identifiers
08.09.2009 w. keller fix error that dbaMulti flag was ignored
25.08.2009 w. keller Frage für Universal TS, Fehler fuer rotate
12.08.2009 w. keller argument end macht save und end
13.11.2008 w. keller kein Absturz auf leerem input
25.09.2008 w. keller geht auch für CDL und PartitonenAttribute
26.06.2008 w. keller scanner geht über recordGrenzen
26.06.2008 w. keller create auf last Line und - 1 gehen jetzt
11.12.2007 w. keller dsSize 32G
26.11.2007 w. keller priqty/secQty immer auf -1
24.09.2007 w. keller priqty/secQty < 1 auf -1 übersetzen
13.07.2007 w. keller remove large option in create tablespace
09.02.2007 w. keller remove // dd * lines if first line is not jcl
07.02.2007 w. keller dssize
05.02.2007 w. keller neu erstellt
toDo & Ideas
load data auf resume no replace umstellen, wegen RTS?
bekommt edit error, wenn letztes Zeile mit ; --> testCase
***********************************************************************/
parse arg args
call errReset 'h'
call jIni
m.debug = 0 /* debug output */
if pos('?', args) > 0 then
exit help()
call adrIsp 'control errors return'
if args = '' then
if adrEdit('macro (args)', '*') <> 0 then
exit errHelp('please run as edit macro')
uArgs = translate(args)
changes = dbaCheck(args)
if wordPos('END', uArgs) > 0 then do
if changes > 0 then
call adrEdit 'save', 0 4
call adrEdit 'end'
end
if wordPos('EX0', uArgs) > 0 | wordPos('END', uArgs) > 0 then
exit 0
exit changes
dbaCheck: procedure expose m.
parse upper arg args
call adrEdit "(cn) = linenum .zl", 4
if cn < 1 then
exit 0
/* call adrEdit 'setUndo on' nützt nicht, initMacro kann
nicht undo't werden ... */
m.cdl = isCdl()
call mCut fatal, 0
call debug 'isCdl' m.cdl
call overrideTree mapReset(os, 'k')
if m.debug then
call overrideTreeShow os
call scanWinIni
call editReadIni
call jReset oMutate(er, 'EditRead'), 1
es = scanSql(er)
if m.cdl then
call scanWinOpts es, 5, 2, 9, 72
lx = 0
m.an.0 = 0
/* jedes create suchen und analysieren -> an */
do forever
lx = seekId(es, lx+1, 'CREATE')
if lx < 1 then
leave
call debug 'seek found CREATE at' lx scanPos(es)
call analyseCreate es, os, an
call jClose es
end
do forever
lx = seekId(es, lx+1, 'ROTATE')
if lx < 1 then
leave
say 'never do a rotate|'
call mAdd fatal, 'fehler: rotate'
call jClose es
end
if m.debug then
call anaShow an
m.wr.0 = 0
/* overrides und adds bestimmen -> wr */
call override an, wr
if m.debug then
do y=1 to m.wr.0
w = wr'.'y
say 'over' m.w.fPos '-' m.w.tPos '=' m.w
end
oCnt = m.wr.0
ddSt = findDDStar(0)
say oCnt 'overrides and' ddSt '//DD*'
if (oCnt + ddSt + m.fatal.0) <= 0 then
return 0
if args ^= 'DBAMULTI' then do
call applyOverrides wr /* apply to edited file */
if ddSt > 0 then
call findDDStar 1
return oCnt + ddSt
end
do forever /* Benutzer muss entscheiden */
say 'bitte wählen Sie'
say ' m = multiClone ohne overrides'
say ' o = override Werte, save und end'
say ' e = edit override Werte'
say ' f = edit ohne override'
parse upper pull w
w = left(strip(w), 1)
if w = 'M' then
exit 0
if w == 'O' | w == 'E' then do
call applyOverrides wr /* apply to edited file */
if ddSt > 0 then
call findDDStar 1
end
if w == 'O' then do
call adrEdit 'SAVE'
call adrEdit 'END'
end
if pos(w, 'OEF') > 0 then
exit 4
say 'ungültige Antwort' w
end
endProcedure dbaCheck
isCdl: procedure expose m.
parse arg lx
if lx = '' then do
if isCdl(1) then
return 1
if isCdl('CREATE') then
return 1
if isCdl('DROP') then
return 1
return 0
end
if ^ datatype(lx, 'n') then do
if adrEdit("seek" lx "word first", 4) = 4 then
return 0
call adrEdit "(lx) = cursor"
end
call adrEdit '(ll) = line' lx
if left(ll, 8) = 'SQLID' then
return subword(ll, 2, 2) = 'SET CURRENT'
if left(ll, 8) = 'CREATE' then
return wordPos(word(ll, 2), 'CREATE ALTER ADMIN --#SET') > 0
if left(ll, 8) = 'ALTER' then
return wordPos(word(ll, 2), 'CREATE ALTER ADMIN --#SET') > 0
if left(ll, 8) = 'DROP' then
return wordPos(word(ll, 2), 'DROP ADMIN --#SET') > 0
return 0
endProcedure isCdl
seekId: procedure expose m.
parse arg es, lx, id
if ^ m.cdl then
return scanSqlSeekId(es, lx, id)
do forever
lx = scanSqlSeekId(es, lx, id, 'WORD 9 80')
if lx < 1 then
return lx
call debug 'seek found CREATE at' lx scanPos(es)
call adrEdit '(ll) = line' lx
if word(left(ll, 8), 1) = 'CREATE' then
return lx
call jClose es
end
endProcedure seekId
/*--- we define the scan structure and overrides
in a tree ---------------------------------------------------*/
overrideTree: procedure expose m.
parse arg rt
ts = overrideTreeNd(rt, 'TABLESPACE', 'TS')
us = overrideTreeNd(ts, 'USING', 'US')
sg = overrideTreeNd(us, 'STOGROUP', 'SG', 'i GSMS')
c = overrideTreeNd(sg, 'PRIQTY', 'PQ', 'n -1')
c = overrideTreeNd(sg, 'SECQTY', 'SQ', 'n -1' , PQ)
c = overrideTreeNd(ts, 'SEGSIZE', 'SE', 'n 64', '|0')
c = overrideTreeNd(ts, 'DSSIZE', 'DS', 'G 16 G')
c = overrideTreeNd(ts, 'NUMPARTS', 'PA', 'n')
c = overrideTreeNd(ts, 'LOCKMAX', 'LM', 'ni SYSTEM')
c = overrideTreeNd(ts, 'LOCKSIZE', 'LS', 'i')
co = overrideTreeNd(ts, 'COMPRESS', 'CR', 'i YES')
br = overrideTreeNd(ts, '(', '(')
c = overrideTreeNd(br, 'PARTITION', 'PR?', 'n')
call mapAdd c, 'USING', us
call mapAdd c, 'COMPRESS', co
call mapAdd br, 'PART', c
ix = overrideTreeNd(rt, 'INDEX', 'IX')
call mapAdd ix, 'USING', us
c = overrideTreeNd(ix, 'COPY', 'CY', 'i NO')
br = overrideTreeNd(ix, '(', '(')
c = overrideTreeNd(br, 'PARTITION', 'PR?', 'n')
call mapAdd c, 'USING', us
call mapAdd br, 'PART', c
return
endProcedure overrideTree
/*--- create a node in the overrideTree with
pa=parent, scan=token, ident,
over=data type and override value, ty=id of type node ------*/
overrideTreeNd: procedure expose m.
parse arg pa, scan, ident, over, ty
ch = mapReset(pa'.'ident, 'k')
call mapAdd pa, scan, ch
m.ch.id = ident
m.ch.att = scan
m.ch.dataType = word(over, 1)
m.ch.overVal = subword(over, 2)
if ty ^== '' then
m.ch.overType = ty
else
m.ch.overType = ident
return ch
endProcedure overrideTreeNd
/*--- show the override tree -----------------------------------------*/
overrideTreeShow: procedure expose m.
parse arg pa, pr
ks = mapKeys(pa)
do kx = 1 to m.ks.0
ch = mapGet(pa, m.ks.kx)
say left(pr m.ks.kx, 20) right(ch, 2) ,
'over' m.ch.overVal 'type' m.ch.overType
call overrideTreeShow ch, pr' '
end
return
endProcedure overrideTreeShow
/*--- analyse a create statement -------------------------------------*/
analyseCreate: procedure expose m.
parse arg m, os, an
if m.m.val ^== 'CREATE' then
call scanErr m, 'analyseCreate but token' m.m.val 'not CREATE'
fp = scanPos(m)
if ^ scanSqlId(m) then
call scanErr m, 'no id'
subTyp = ''
do while wordPos(m.m.val, 'LARGE LOB UNIQUE WHERE') > 0
subTyp = strip(subTyp m.m.val)
if m.m.val = 'WHERE' then do
call checkIds m, 'NOT', 'NULL'
subTyp = subTyp 'NOT NULL'
end
if ^ scanSqlId(scanSkip(m)) then
call scanErr m, 'no id'
end
typ = m.m.val
if ^ mapHasKey(os, typ) then do
call scanSqlQuId scanSkip(m)
call debug 'analyseCreate skipping' subTyp typ 'name' m.m.val
return
end
nP = scanPos(m)
if ^ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'name missing for create' subtyp typ
na = m.m.val
on = ''
if typ = 'TABLESPACE' then do
call checkIds m, 'IN'
if ^ scanSqlId(scanSkip(m)) then
call scanErr m 'dbName expected'
na = m.m.val'.'na
end
else if typ = 'INDEX' then do
/* wir muessen ueber die Column List scannen,
damit wir sie nicht mit der PartitionListe verwechseln*/
if ^ (scanSqlId(m) & m.m.val = 'ON') then
call scanErr m, 'ON expected after index' na
if ^ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
on = 'on' m.m.val
/* aux tables haben keine column list ||| */
if (scanSqlClass(m) & m.m.sqlClass = '(') then
call scanSqlSkipBrackets m, 1
end
say left('analyse', 8) leftl(na, 17) strip(subtyp typ) on
a = mapReset(mAdd(an, mapGet(os, typ)), 'k')
m.a.name = na
m.a.subType = subTyp
m.a.fPos = fP
m.a.nPos = nP
call analyseNode m, a
call checkFatal a
tP = scanPos(m)
if m.m.sqlClass = ';' then
tP = word(tP, 1) word(tP, 2) - 1
m.a.tPos = tP
return
endProcedure analyseCreate
/*--- analyse the substatement at scanner sc,
according to the description in node nd.1 -----------------*/
analyseNode: procedure expose m.
parse arg sc, nd.1, stopper
top = 1 /* top of node stack */
do while scanSqlClass(sc) & pos(m.sc.sqlClass, ';'stopper) < 1
if m.sc.sqlClass = 'i' then
att = m.sc.val
else if pos(m.sc.sqlClass, '()') > 0 then
att = m.sc.sqlClass
else
iterate
do ox=top by -1 to 1 /* search id in all nodes in stack */
nd = nd.ox
os = m.nd
if mapHasKey(os, att) then
leave
end
if ox < 1 then do
if att == '(' then
call scanSqlSkipBrackets sc, 1
iterate
end
osNx = mapGet(os, att) /* the os node */
chfPos = scanPos(sc)
ty = m.osNx.dataType
if ty ^== '' then do /* scan the value of the attribute */
if ty = 'i' then
res = scanSqlId(sc)
else if ty = 'n' then
res = scanSqlNum(sc)
else if ty = 'G' then
res = scanSqlNumUnit(sc, 'G M K')
else if ty = 'ni' then do
res = scanSqlNum(sc)
if \ res then
res = scanSqlId(sc)
end
else
call err 'overwrite type' ty 'not supported'
if ^ res then
call scanErr sc, ty 'value expected after' att
res = m.sc.val
end
chId = m.osNx.id
if right(chId, 1) = '?' then
chId = chId || res
ch = mapReset(nd.ox'.'chId, 'k') /* the new analysis node*/
m.ch.fPos = chfPos
m.ch.tPos = scanPos(sc)
if ty ^== '' then
m.ch.val = res
call mapAdd nd.ox, chId, osNx
if att = '(' then do
top = ox
call analyseNode sc, ch, ')'
if m.sc.sqlClass ^== ')' then
call scanErr sc, 'closing ) expected'
iterate
end
top = ox+1 /* pop higher nodes and push new one */
nd.top = ch
end
return
endProcedure analyseNode
/*--- show the the root analysises in stem a -------------------------*/
anaShow: procedure expose m.
parse arg a
do x=1 to m.a.0
call anaShow1 a'.' || x
end
return
/*--- show the analysis node a and its subnodes ----------------------*/
anaShow1: procedure expose m.
parse arg a
os = m.a
say a '->' os
if ^ abbrev(os, 'OS.') then
return
say ' val' m.a.val 'fr' m.a.fPos 'to' m.a.tPos
if wordPos(m.os.id, 'TS IX') > 0 then
say ' name' m.a.name '@' m.a.nPos
ks = mapKeys(a)
do kx = 1 to m.ks.0
call anaShow1 a'.'m.ks.kx
end
return
/*--- show the analysis node a and its subnodes ----------------------*/
checkFatal: procedure expose m.
parse arg a
if mapHasKey(a, 'PA') & mapHasKey(a, 'SE') then
if mapGet(a,'SE.VAL') <> 0 then do
say 'do you really want an universal tablespace' m.a.name,
'numParts' mapGet(a,'PA.VAL') 'segSize' mapGet(a,'SE.VAL')
parse upper pull yes
if \ (abbrev(yes, 'Y') | abbrev(yes, 'J')) then
call mAdd fatal, 'fehler: universal TS' m.a.name
end
return
endProcedure checkFatal
/*--- generate the override for all anaysis root nodes ---------------*/
override: procedure expose m.
parse arg an, wr
do ax=1 to m.an.0
call overrideNode an'.'ax, an'.'ax, wr
end
return
endProcedure override
/*--- create the necessary overrides for node rt and it's subnodes ---*/
overrideNode: procedure expose m.
parse arg rt, an, wr
os = m.an
doOv = m.os.overVal <> '' & m.os.overVal <> m.an.val
if doOv & abbrev(m.os.overType, '|') then
doOv = m.an.val <> substr(m.os.overType, 2)
if doOv & m.os.overType == 'LM' then do
ls = mapGet(rt, 'LS.VAL', '')
doOv = m.an.val = 0 & \ abbrev(ls, 'TABL', 1)
end
if doOv then
call overrideAtt rt, an, os, wr
if m.os.overType = 'TS' then do
wx = wordPos('LARGE', m.an.subType)
if wx > 0 then do
o = m.an.subType
n = subWord(o, 1, wx-1) subWord(o, wx+1)
call overrideOne wr, n 'TABLESPACE', m.an.fPos, m.an.nPos
call overrideSay 'override', rt, 'subType', n, o
end
end
ids = ''
keys = mapKeys(an)
do ax=1 to m.keys.0
nd = an'.'m.keys.ax
o1 = m.nd
ids = ids m.o1.id
call overrideNode rt, nd, wr
end
keys = mapKeys(os)
do ox=1 to m.keys.0
nd = mapGet(os, m.keys.ox)
if wordPos(m.nd.id, ids) < 1 then
call overrideAdd rt, an, nd, wr
end
return
endProcedure overrideNode
/*--- add to wr the override attribute osprefixed by tokens in scPa
for analysis node an with root rt pre ----------------------*/
overrideAdd: procedure expose m.
parse arg rt, an, os, wr, scPa
scPa = strip(scPa m.os.att)
if pos('?', os an) > 0 then
return
if m.os.overVal ^== '' then do
ov = m.os.overVal
ty = m.os.overType
jj = m.os.id
if jj = 'SE' then
if mapHasKey(rt, 'PA') | pos('LOB', m.rt.subType) > 0 then
ov = 0
if ty = 'DS' then
if ^mapHasKey(rt, 'PA') | pos('LOB', m.rt.subType) > 0 then
ty = ''
if ty = 'LM' then do
ls = mapGet(rt, 'LS.VAL', '')
if ls == '' | ls == 'ANY' | abbrev(ls, 'TABL', 1) then
ty = ''
end
if ty <> '' then do
call overrideOne wr, scPa ov,
, m.an.tPos, m.an.tPos
call overrideSay 'add', rt, scPa, ov
scPa = ''
end
else
call debug 'no overrideAdd' scPa
end
keys = mapKeys(os)
do ox=1 to m.keys.0
call overrideAdd rt, an, mapGet(os, m.keys.ox), wr, scPa
end
return
endProcedure overrideAdd
/*--- override an attribute of cp with overrideNode on ---------------*/
overrideAtt: procedure expose m.
parse arg rt, an, os, wr
o = overrideOne(wr, m.os.overVal, m.an.fPos, m.an.tPos)
call overrideSay 'override', rt, m.os.att, m.os.overVal,m.an.val' '
return 0
endProcedure overrideAtt
/*--- create on override node an add it ------------------------------*/
overrideOne: procedure expose m.
parse arg wr, new, fp, tp
o = mAdd(wr, new)
m.o.fPos = fp
m.o.tPos = tp
return o
endProcedure overrideOne
/*--- say what we want to override -----------------------------------*/
overrideSay: procedure expose m.
parse arg f, rt, att, new, old
m = left(f, 8) leftl(m.rt.name, 17) leftl(att, 8) leftl(new, 8)
if old ^== '' then
m = m 'from' old
say m
return
endProcedure overrideSay
/*--- edit a sequence of overrides into data -------------------------*/
applyOverrides: procedure expose m.
parse arg wr
call adrEdit "(w) = linenum .zl"
w = max(w, m.wr.0) + 10
w = length(w)
do x=1 to m.wr.0
m.si.x = right(word(m.wr.x.fPos, 1)+0, w, 0) ,
right(word(m.wr.x.fPos, 2)+0, 3, 0) right(x, w)
end
m.si.0 = m.wr.0
call sort si, so
delta = 0
cx = 1
wx = word(m.so.cx, 3)
do while cx <= m.so.0
lx = word(m.wr.wx.fPos, 1)
line = applyGetLine(lx+delta)
call mAdd mCut(wrk, 0), left(line, word(m.wr.wx.fPos, 2)-1)
lStX = lx
wy = wx
do forever
call app72 wrk, m.wr.wx
cx = cx + 1
if cx > m.so.0 then
leave
wx = word(m.so.cx, 3)
if word(m.wr.wx.fPos, 1) > word(m.wr.wy.tPos, 1) then
leave
else if m.wr.wx.tPos == m.wr.wy.tPos ,
& (m.wr.wx.fPos == m.wr.wy.fPos ,
|m.wr.wx.fPos == m.wr.wx.tPos) then
nop
else if word(m.wr.wx.fPos, 1) <> word(m.wr.wy.tPos, 1) then
call err 'bad sequence in override'
else if word(m.wr.wx.fPos, 2) <= word(m.wr.wy.tPos, 2) then
do
say wy m.wr.wy.tPos
call err 'overlap in override'
end
else do
if lx <> word(m.wr.wx.fPos, 1) then do
lx = word(m.wr.wx.fPos, 1)
line = applyGetLine(lx+delta)
end
px = word(m.wr.wy.tPos, 2)
call app72 wrk, substr(line, px,
, word(m.wr.wx.fPos, 2) - px), px
wy = wx
end
end
if lx <> word(m.wr.wy.tPos, 1) then do
lx = word(m.wr.wy.tPos, 1)
line = applyGetLine(lx+delta)
end
px = word(m.wr.wy.tPos, 2)
call app72 wrk, substr(line, px, 72+1-px), px, 1
do xx = lStx to lx
call adrEdit 'delete' (lStx+delta)
end
delta = delta + lStX - lx - 1
do xx=1 to m.wrk.0
if m.cdl then
li = left(m.applyGetLineMark || m.wrk.xx, 80)
else
li = left(m.wrk.xx, 72)m.applyGetLineMark
call adrEdit "line_after" (lx+delta) "= (li)"
delta = delta + 1
end
end
do fx=1 to m.fatal.0
li = copies('CREATE ', m.cdl) m.fatal.fx
call adrEdit "line_after 1 = (li)"
end
return
endProcedure applyOverrides
/*--- return the sql portion of line lx
and put the mark field into m.applyGetLineMark -------------*/
applyGetLine: procedure expose m.
parse arg lx
call adrEdit "(line) = line" (lx)
if m.cdl then do
m.applyGetLineMark = left(line, 8)
if m.applyGetLineMark <> 'CREATE' then
call err 'bad applyGetLine mark' m.applyGetLineMark ,
'in line' lx':' strip(line, 't')
return substr(line, 9, 72)
end
else do
m.applyGetLineMark = substr(line, 73, 8)
return left(line, 72)
end
endProcedure applyGetLine
/*--- append to stem st string val, at position miLe
if fix=1 exactly at the position else can shift to right ---*/
app72: procedure expose m.
parse arg st, val, miLe, fix
sx = m.st.0
li = strip(m.st.sx, 't')
if miLe ^== '' then do
vx = verify(val, ' ')
if vx = 0 then
miLe = miLe + length(val)
else
miLe = miLe + vx - 1
end
val = strip(val)
if fix = 1 then do
if length(li)+1 >= miLe then do
sx = sx + 1
li = ''
end
nn = left(li, miLe-1)val
end
else do
if length(li)+1 < miLe then
nn = left(li, miLe-1)val
else if length(li val) < 72 then
nn = li val
else
nn = left(li, 80)val
do while length(nn) >= 72
m.st.sx = left(nn, 72)
sx = sx + 1
nn = substr(nn, 73)
end
end
m.st.sx = nn
m.st.0 = sx
return
endProcedure app72
/*--- scan from scanner m the ids arg(2) ... arg(arg()) --------------*/
checkids: procedure expose m.
parse arg m
do ax=2 to arg()
if ^ scanSqlId(scanSkip(m)) & m.m.val <> translate(arg(ax)) then
call scanErr m, 'sqlId' arg(ax) 'expected'
end
return
endProcedure checkIds
/*--- find the errously genereate // DD * statements ----------------*/
findDDStar: procedure expose m.
parse arg rem
parse arg m, lx, cmd
c = 0
call adrEdit "cursor = 1"
do while adrEdit("seek '//' 1", 4) = 0 /* find each command */
call adrEdit "(lx) = cursor"
call adrEdit "(li) = line" lx
if lx = 1 then do
say 'first line looks like jcl, no search for //DD*'
return 0
end
if space(li, 0) ^== '//DD*' then do
if ^ rem then
say 'ignoring // line' lx strip(li,'t')
end
else do
c = c + 1
if rem then do
call adrEdit 'delete' lx
call adrEdit "cursor =" (lx-1)
end
end
end
return c
endProcedure findDDStar
/*--- fill src with spaces to get at least length len ----------------*/
leftl: procedure
parse arg src, len
if len > length(src) then
return left(src, len)
else
return src
endProcedure leftl
/*--- define reader reading edit data from line lx -------------------*/
editReadIni: procedure expose m.
call classNew "n EditRead u JRW", "m",
, "jRead return editRead(m, var)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return m
endProcedure editReadIni
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m, var
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) ^= 0 then
return 0
m.var = ll
return 1
endProcedure editRead
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort 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, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
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 jReset m.m.rdr, fx
call jOpen m, '<', fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'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 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = '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.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' 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
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
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
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlStmt: procedure expose m.
parse arg m, delim
if delim == '' then
delim = ';'
res = ''
vChrs = strip('''"/'delim || left(m.m.scanComment, 1))
do forever
if scanSpaceNl(m) then
if right(res, 1) \== ' ' then
res = res' '
if scanVerify(m, vChrs, 'm') then
res = res || m.m.tok
else if scanString(m) then
res = res || m.m.tok
else if scanLit(m, delim) then do
m.m.val = res
return 1
end
else if scanChar(m, 1) then do
res = res || m.m.tok
end
else do
m.m.val = res
return res \= ''
end
end
endProcedure scanSqlStmt
/* 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 scanReadIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m, arg(3) ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(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 scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
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 m
endProcedure scanWinOpts
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
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.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
parse arg m
m.m.atEnd = 'still closed'
call jClose m.m.rdr
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.rdr, 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
call scanWinRead m
if scanVerify(m, ' ') then do
res = 1
iterate
end
else if scanLit(m, '/*') then do
ex = pos('*/', m.m.src, m.m.pos+2)
if ex <= m.m.pos then
return scanErr(m, '*/ missing after /*')
m.m.pos = ex+2
res = 1
end
else do
cl = length(m.m.scanComment)
np = scanWinNlPos(m)
if \ ( cl>0 & m.m.pos+cl <= np & m.m.scanComment ,
== substr(m.m.src, m.m.pos, cl)) then
return res
m.m.pos = np
res = 1
end
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 '\n'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 scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead 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.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
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 scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- 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, onlyIfMatch
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
if onlyIfMatch == 1 then
nx = m.m.pos
else
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 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- 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
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
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
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
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.rdr \== '' then
interpret 'res = ' objMet(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.rdr \== '' then
interpret 'return' objMet(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.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, opt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = jCat1(m.line)
if \ abbrev(opt, '-', 1) then
do while jRead(m, line)
res = res || opt || m.line
end
else if opt == '-s' then
do while jRead(m, line)
res = res strip(m.line)
end
else if opt == '-72' then
do while jRead(m, line)
res = res || left(m.line, 72)
end
call jClose m
return res
endProcedure jCatLines
jCat1: procedure expose m.
parse arg v, opt
if \ abbrev(opt, '-', 1) then
return v
if opt == '-s' then
return strip(v)
if opt == '-72' then
return left(v, 72)
call err 'bad opt' opt 'in jCat1('v',' opt')'
endProcedure jCat1
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRWO', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
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
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), " ")')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat 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 || '.'
m.m.area.0 = 0
call mNewArea
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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBADO) cre=2009-11-10 mod=2009-11-10-17.27.57 A540769 ----
call sqlConnect DBOF
$=pds=DSN.DBA.ZUEGEL.NOV.RUN
$=chgs=DSN.DBA.ZUEGEL.NOV.JCL(ALL)
$=run = DSN.DBA.ZUEGEL.NOV.RUN
m.run.1 = 'DSN.DBA.ZUEGEL.NOV.RUNDIPRO'
m.run.2 = 'DSN.DBA.DBOF.RUN.JCL'
m.run.0 = 2
$;
$<$chgs
$@for li $@¢
parse value $li with aCh aTi aPl .
call sqlPreAllCl 1, 'select changeid, name, status' ,
'from s100447.adbChg',
'where name like '''aCh'.%''',
, c, ':m.st.sx.ch, :m.st.sx.na, :m.st.sx.st'
fx = -1
do cx=1 to m.c.0
if wordPos(m.c.cx.st, 'COMPLETE CANCEL') > 0 then
iterate
if fx > 0 then
call err 'multiple' aCh':' ,
|| cx m.c.cx.ch m.c.cx.na m.c.cx.st
fx = cx
end
if fx < 1 then do
$$- 'ch' aCh 'not found' aPl
iterate
end
else if m.c.fx.st \== 'ANALYZED' then do
$$- 'ch' aCh':'cx m.c.fx.ch m.c.fx.na m.c.fx.st
iterate
end
mbr = 'E'right(0 + m.c.fx.ch, 7, 0)
ex = ''
do rx=1 to m.run.0
if sysDsn("'"m.run.rx"("mbr")'") = OK then
ex = ex rx
end
if words(ex) = 1 then
msg = 'once'
else if words(ex) < 1 then
msg = 'miss'
else
msg = 'dupp'
$$- 'ch' aCh msg ex':'fx m.c.fx.ch m.c.fx.na m.c.fx.st
if 1 then do
job = 'Y'left(aCh, 7)
ey = word(ex, 1)
call readDsn m.run.ey'('mbr')', j.
jx = pos(' JOB ', j.1)
if jx < 1 | jx > 16 then
call err 'no jobCard in' aCh':' j.1
j.1 = '//'job strip(substr(j.1, jx))
call writeDsn $run'('aCh')', j., , 1
end
$!
$#end
$#out 20091110 17:17:31
ch SV30003C once 2:1 2441. SV30003C.0.004.IMP ANALYZED
ch SV30004C once 2:1 2501. SV30004C.0-1.008.IMP ANALYZED
ch SV30005C once 1:1 2522. SV30005C.0.004.IMP ANALYZED
ch SV30002W once 1:1 2292. SV30002W.0.003.IMP ANALYZED
ch AV15010C once 2:1 2541. AV15010C.0-6.008.IMP ANALYZED
ch AVIN017C once 1:1 2248. AVIN017C.0.003.IMP ANALYZED
ch DP08004C once 1:1 2316. DP08004C.0-2.009.IMP ANALYZED
ch EX01001C once 1:1 2269. EX01001C.0.003.IMP ANALYZED
ch PC11005C once 1:1 2273. PC11005C.1.003.IMP ANALYZED
ch RB01016C once 1:1 2249. RB01016C.0-1.004.IMP ANALYZED
ch RV01007C once 1:1 2286. RV01007C.0-1.005.IMP ANALYZED
ch SV04001C once 1:1 2275. SV04001C.0.003.IMP ANALYZED
ch SV70005C once 2:1 2462. SV70005C.0-2.011.IMP ANALYZED
ch TN01050C once 1:1 2288. TN01050C.0.003.IMP ANALYZED
ch VDPS441C once 1:1 2582. VDPS441C.0-A.040.IMP ANALYZED
ch VDPS442C once 1:1 2289. VDPS442C.0.004.IMP ANALYZED
ch VDPS443C once 1:1 2318. VDPS443C.0.003.IMP ANALYZED
ch VDPS444C once 1:1 2343. VDPS444C.0-1.007.IMP ANALYZED
ch WI03014C once 1:1 2341. WI03014C.0-1.006.IMP ANALYZED
ch WQ01035C once 2:1 2561. WQ01035C.0.004.IMP ANALYZED
ch YMF01A1C not found JCL
ch NZ01014C once 1:1 2272. NZ01014C.0.003.IMP ANALYZED
ch DG01031C not found ALT
ch ED02001C once 1:1 2268. ED02001C.0.003.IMP ANALYZED
ch ID01010C once 1:1 2270. ID01010C.1-2.009.IMP ANALYZED
ch LC02003C once 1:1 2271. LC02003C.0.003.IMP ANALYZED
ch TN01051C once 1:1 2362. TN01051C.0-1.007.IMP ANALYZED
ch TP01007C once 1:1 2276. TP01007C.0.003.IMP ANALYZED
ch TR03003C once 1:1 2321. TR03003C.0.003.IMP ANALYZED
ch WB01007C not found JCL
ch WB11013C once 1:1 2278. WB11013C.0.003.IMP ANALYZED
ch WB12021C once 1:1 2279. WB12021C.0-1.006.IMP ANALYZED
ch WB12022C once 1:1 2280. WB12022C.0-1.006.IMP ANALYZED
ch WI01002C once 2:1 2581. WI01002C.0.003.IMP ANALYZED
ch WL07002C once 1:1 2342. WL07002C.0-2.009.IMP ANALYZED
ch SN01045C once 1:1 2250. SN01045C.4.006.IMP ANALYZED
ch SN01046C once 1:1 2251. SN01046C.4.006.IMP ANALYZED
ch SN01048C once 1:1 2287. SN01048C.4.006.IMP ANALYZED
ch SN01049C dupp 1 2:1 2361. SN01049C.7.026.IMP ANALYZED
ch WQ01033C once 1:1 2290. WQ01033C.0.003.IMP ANALYZED
}¢--- A540769.WK.REXX(DBAMULTI) cre=2009-09-08 mod=2009-09-08-10.58.02 A540769 ---
/* rexx ****************************************************************
synopsis: dbaMulti ¢-r¦s¦u¦?! <member>
start multiClon for <member>
<member> must end with a W (new) or C (change)
as a tso command member must be 8 characters long
as an editmacro mbr defaults to the member being edited
and a single character overwrites its last character
dbaCheck applies the CS defaults (if run as editMacro)
if the member exists already in a WSL
it is removed, if the user whishes
the input dataset is overwritten for mbr
the appropriate mulitCloneJob is started
options:
-s silent: remove members without asking
-u unchecked: do not run dbaCheck
-? or ?: this help
***********************************************************************
02.06.2008 uses dbx
*/ /* end of help --- history
04.12.2007 copies wsl to DSN.DBA.CLON.WSLSRC
05.01.2007 uses DbaCheck
20.11.2006 runs also in RZ2, RZ4 RR2 and RR4
**********************************************************************/
nd = sysvar(sysnode)
libPre = 'DSN.DBA.'
if nd = 'RZ1' then
libMid = 'DBAF DBBA DBLF DBOC DBTF DBZF DVTB'
else if nd = 'RZ2' | nd = 'RR2' then
libMid = 'DBOF'
else if nd = 'RZ4' | nd = 'RR4' then
libMid = 'DBCP DBII DBOL DVBP'
else
call errHelp 'rz' nd 'is not supported'
libSuf = '.WSL'
multiInp = 'DSN.DBA.MULTI.CLON.INPUT'
multiNew = 'DSN.DBA.MULTI.CLON.NEW.JCL'
multiChg = 'DSN.DBA.MULTI.CLON.CDL.JCL'
multiCopy= 'DSN.DBA.CLON.WSLSRC'
parse arg args
call adrIsp 'control errors return'
mbr = ''
opt = ''
isMacro = 0
if args = '' then
if adrEdit('macro (args)', 20) == 0 then
isMacro = 1
if pos('?', args) > 0 then
return help()
do ax=1 to words(args)
wo = translate(word(args, ax))
if left(wo, 1) = '-' then do
if verify(wo, '-URS') <> 0 then
call errHelp 'bad option "'wo'" in "'args'"'
opt = opt substr(wo, 2)
end
else if mbr ^== '' then
call errHelp 'more than one member "'wo'" in "'args'"'
else
mbr = wo
end
if pos('U', opt) < 1 then do
res = dbaCheck('dbaMulti')
if res = 4 then
return
else if res ^== 0 then
call err 'dbaCheck returns' res
end
if length(mbr) <= 1 & isMacro then do
fnd = 'DSN.DBA. first'
if adrEdit("seek" fnd, 4) ^= 0 then
call err 'could not find member, dsn.dba not found'
call adrEdit "(lx, cx) = cursor"
call adrEdit "(line) = line" lx
sx = cx + 8
do 4
ex = verify(line, ' .', 'm', sx)
if ex <= sx then
ex = 1+length(line)
em = strip(substr(line, sx, ex-sx))
if length(em) = 8 then
leave
sx = ex+1
end
if length(em) <> 8 then
call errHelp 'no mbr detected in line' lx':' line
mbr = overlay(mbr, em, 9 - length(mbr))
say 'detected qualifier' em 'in edit data yielding member' mbr
end
if length(mbr) <> 8 then
call errHelp 'mbr "'mbr'" should have length 8'
else if pos(right(mbr, 1), 'CW') = 0 then
call errHelp 'mbr "'mbr'" should end with C or W'
doRm = pos('S', opt) > 0
do mx = 1 to words(libMid) while ^doRm
dsn = jcl2dsn(libPre || word(libMid, mx) || libSuf"("mbr")")
sd = sysDsn(dsn)
if sd = 'OK' then do
if pos('S', opt) < 1 then do
say 'remove existing mbr' mbr 'in' dsn' (r for remove)?'
parse upper pull a
if left(a, 1) ^== 'R' then do
say 'exiting because answer was' a 'and not r'
exit
end
doRm = 1
end
end
else if sd ^== 'MEMBER NOT FOUND' then do
call err 'unexpected sysDsn('dsn') =' sd
end
end
call dbx cloneWsl '*' mbr doRm
if isMacro & nd = 'RZ1' then do
call adrEdit '(zl) = lineNum .zl'
do x=2 to zl+1
call adrEdit '(li) = line' (x-1)
li.x = li
end
li.1 ='-- Copied by dbamulti for' userid() 'on' date() 'at' time()
call writeDsn multiCopy'('left(mbr,7)'Q)', li., zl+1
end
exit
/* 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
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
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
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
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
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
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
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd
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 to 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
leave
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
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
return atts '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
/* 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
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
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
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(DBARB) cre=2011-09-20 mod=2015-08-31-11.49.57 A540769 ----
/* rexx ****************************************************************
synopsis: DBARB (-(a¨n¨i¨t)+)? subsys?
version vom 21.08.2015
edit macro to generate rebinds for a worklist
function:
search sql DDL statements in currently edited data
find packages dependent on created/dropped/altered1
tablespaces, tables, views, indexes, aliases or synonyms,
append rebind statements for these packages and
remove existing rebinds at the end of the data
options
a = alle Packages (default)
n = only new packages = aktive packages
= 1bef7: das neueste Package älter 1 Woche und alle jüngeren
i = info line für jedes package
t = rebinds für tso dsn processor
ohne t für ca rc/migrator batchprozessor
subsys may be one of the following
? for this help
empty for deduce subsys from WSLLib, qualifiers or sysnode
x for DBxF
yy for DByy
zzzz for zzzz
** history *************************************************************
31.08.2015 do not fail when removing bind triggers
************* end of help */ /****************************************
12.05.2014 allow comments between ca rebinds
9.05.2014 version für CA batchProzessor und option t (für alt)
19.01.2012 options -ani und neue copies
20.09.2011 defaults: RZZ ==> DE0G, RZ8 ==> DD0G
14.12.2006 scan start robuster gemacht gegen ScanErr
20.10.2006 synonym und tablespace eingebaut
19.10.2006 viewDep muss nicht berücksichtigt werden, weil DB2
mit einem Objekt auch alle abhängigen Views löscht
***********************************************************************/
parse arg args
call errReset 'h'
call scanWinIni
m.debug = 0 /* debug output */
m.cmp = userid() = 'F540769' /* compare old and new rebinds */
call adrIsp 'control errors return'
isMacro = 0
if word(args, 1) == 'isMacro' then do
isMacro = 1
args = subword(args, 2)
end
else if args = '' then do
if adrEdit('macro (args)', 20) == 0 then
isMacro = 1
end
if ^ isMacro then
call errHelp 'not started as editMacro'
if pos('?', args) > 0 then
exit help()
m.types = 'R T V X A S'
m.typNames = 'tablespace table view index alias synonym'
m.cmp.0 = 0
do tyx=1 to words(m.types)
typ = word(m.types, tyx)
m.obj.typ.0 = 0
end
args = translate(strip(args))
m.opt = ''
if abbrev(args, '-') then do
m.opt = substr(word(args, 1), 2)
args = subWord(args, 2)
end
m.forCa = pos('T', m.opt) < 1
/* analyze ddl in data
and extract changed db2 objects */
if isMacro then do
if m.forCa then
call removeRebinds
call searchObjects
end
li = '' /* format and display counts */
do tyx=1 to words(m.types)
typ = word(m.types, tyx)
li = li',' m.obj.typ.0 word(m.typNames, tyx)
end
li = substr(li, 3)
say 'found' li
/* find db2 subsystem */
m.subsys = dbSubSys(translate(args))
/* show db2 objects in data */
call adrEdit '(origZl) = lineNum .zl'
call appLine '-- generating rebinds in' m.subsys ,
'at' time('n') date('e') 'for' userid()
call appLine '-- for' li
do tyx=1 to words(m.types)
typ = word(m.types, tyx)
tNa = left(word(m.typNames, tyx), 10)
do x=1 to m.obj.typ.0
call appLine '-- ' tNa m.obj.typ.x
end
end
/* search dependent packages in db2 catalog */
sql = genSql()
if sql ^== '' then do
sp = left('-- rebind old state', 72-39-2)
say 'connecting to' m.subsys
call sqlConnect m.subsys
call sqlPreOpen 1, sql
cnt = 0
new = 0
/* fetch each package and write rebind */
do while sqlFetchInto(1, ':coll, :name, :vers, :type, :info, :bef7')
cnt = cnt + 1
if bef7 == 0 then
new = new + 1
else if pos('N', m.opt) > 0 then
iterate
coll = strip(coll)
name = strip(name)
vers = strip(vers)
if m.forCa then do
call appLine '.CALL DSN PARM('m.subsys')'
call appLine '.DATA'
end
if type == 'T' then
call appLine 'REBIND TRIGGER PACKAGE('coll'.'name')'
else
call appLine 'REBIND PACKAGE('coll'.'name'.('vers'))'
if m.forCa then do
call appLine '.ENDDATA'
m.sync = m.sync + 1
call appLine ".SYNC" m.sync "'rebind" name"'"
end
if pos('I', m.opt) > 0 then
call appLine ' --'info 'bef7='bef7
end
call sqlClose 1
if pos('N', m.opt) > 0 then
say 'rebind' new 'new of total' cnt 'packages'
else
say 'rebind' cnt 'including' new 'new packages'
end
if \ m.forCa then
call deleteRebindsUntil origZl
if m.cmp then
call cmpPrint
call sqlDisconnect
exit
/--- search db2 objects changed in the ddl ---------------------------*/
searchObjects: procedure expose m.
sqls = 'CREATE ALTER DROP'
mr = scanSql(mNew('EditRead', 0))
do sx =1 to words(sqls) /* for each sql command */
s1 = word(sqls, sx)
lx = 0
do forever
if lx > 0 then
call jClose mr
lx = scanSqlSeekId(mr, lx+1, s1) /* find each command*/
if lx < 1 then
leave
typ = sqlId(mr)
if wordpos(typ, 'UNIQUE LARGE LOB') > 0 then
typ = sqlId(mr)
if typ = '' then do
if s1 = 'DROP' then do
qq = translate(left(m.mr.src, m.mr.pos-1))
qx = words(qq)
if word(qq, qx) == 'DROP' & word(qq,qx-1) == 'ON' ,
& word(qq,qx-2) == 'RESTRICT' then
iterate
end
call scanErr mr, 'object type expected'
end
if wordPos(typ, translate(m.typNames)) <= 0 then
iterate
tyCh = word(m.types, wordPos(typ, translate(m.typNames)))
if s1 ^= 'CREATE' then do
nm = sqlQuId(mr)
end
else if typ = 'INDEX' then do
nm = sqlQuId(mr)
if sqlId(mr) ^== 'ON' then
call scanErr mr, 'ON expected after create index' nm
call addObj t, sqlQuId(mr)
end
else if typ = 'TABLESPACE' then do
nm = sqlDeId(mr)
if sqlId(mr) ^== 'IN' then
call scanErr mr,
, 'IN expected after create tablespace' nm
nm = sqlDeId(mr)'.'nm
end
else if typ = 'SYNONYM' then do
nm = sqlDeId(mr)
if sqlId(mr) ^== 'FOR' then
call scanErr mr,
, 'FOR expected after create synonym' nm
nm = sqlDeId(mr)'.'nm
end
else do
nm = sqlQuId(mr)
end
call addObj tyCh, nm
end /* each command found */
end /* each sql command */
return
endProcedure searchObjects
removeRebinds: procedure expose m.
call adrEdit "cursor = .zf"
m.sync = 1000000
call adrEdit '(ll) = lineNum .zl'
do forever
if adrEdit("seek 'rebind' word", 4) <> 0 then do
say 'no rebind found'
return
end
call adrEdit "(fx) = cursor"
call adrEdit "(LI) = LINE" fx
lw = translate(subword(li, 1, 3))
call adrEdit "(L1) = LINE" (fx-1)
call adrEdit "(L2) = LINE" (fx-2)
if (abbrev(lw, 'REBIND PACKAGE') ,
| abbrev(lw, 'REBIND TRIGGER PACKAGE')) ,
& word(l1, 1) = '.DATA' ,
& space(subWord(l2, 1, 2), 1) == '.CALL DSN' then
leave
end
rbC = 0
rbX = fx-2
syX = ''
do forever
call adrEdit "(LI) = LINE" fx
lw = translate(subword(li, 1, 3))
if \ (abbrev(lw, 'REBIND PACKAGE') ,
| abbrev(lw, 'REBIND TRIGGER PACKAGE')) then
leave
rbC = rbC + 1
if adrEdit("seek .ENDDATA 1", 4) <> 0 then do
call err 'no endData after line' lx
return
end
call adrEdit "(fx) = cursor"
rbY = fx
do fx=fx+1 to ll
call adrEdit "(LI) = LINE" fx
if left(li, 72) = '' | abbrev(word(li, 1), '--') then
iterate
if abbrev(li, '.SYNC') then do
rbY = fx
if syX = '' then
syX = word(li, 2)
syY = word(li, 2)
iterate
end
leave
end
if fx>ll | \ abbrev(space(li, 1), '.CALL DSN PARM(') then
leave
call adrEdit "(L1) = LINE" (fx+1)
if word(l1, 1) \== '.DATA' then
call err 'bad .data line' (fx+1)':' l1
fx = fx + 2
end
say rbC 'rebinds' rbX '-' rbY 'sync' syX syY
m.sync = syX
do fx=fx to ll
call adrEdit "(LI) = LINE" fx
if li <> '' & \ abbrev(word(li, 1), '--') then do
say 'bad line after binds' fx':' li
do fy=fx-20 to fx
call adrEdit "(Ly) = LINE" fy
say fy':' strip(ly, 't')
end
call err 'bad line after binds' fx':' li
end
end
rr = '--' rbC 'rebinds in lines' rbx '-' rby 'deleted'
call adrEdit "line" rbx "= (rr)"
call adrEdit "delete" (rbX+1) rbY
say 'deleted' rbC 'rebinds lines' rbX rbY
return
endProcedure removeRebinds
/*--- add a db2 object nm of type typ to the list,
if not done already -----------------------------------*/
addObj: procedure expose m.
parse arg typ, nm
if symbol('m.obj.typ.nm') ^= 'VAR' then do
nx = m.obj.typ.0 + 1
m.obj.typ.0 = nx
m.obj.typ.nx = nm
m.obj.typ.nm = nx
end
return
endProcedure addObj
/*--- return the sql to retrieve the packages
dependent on db2 objects in out list ----------------------*/
genSql: procedure expose m.
m.obj.ow.0 = 0
cntTav = 0
cntIdx = 0
/* build lists of names by qualifier */
do tyx=1 to words(m.types)
typ = word(m.types, tyx)
do ox=1 to m.obj.typ.0
qu = anaQualIdent(m.obj.typ.ox)
cntTav = cntTav + 1
if symbol('m.obj.ow.qu') ^== 'VAR' then do
call addObj ow, qu
m.tav.qu = m.ident
m.idx.qu = ''
end
else do
m.tav.qu = m.tav.qu"," m.ident
end
if typ == 'X' then do
/* additional list for indexes */
cntIdx = cntIdx + 1
if m.idx.qu = '' then
m.idx.qu = m.ident
else
m.idx.qu = m.idx.qu"," m.ident
end
end
end
if cntTav = 0 & cntIdx = 0 then
return ''
do y=1 to m.debug * m.obj.ow.0 /* debug lists */
qu = m.obj.ow.y
say y 'qual' qu 'tav:' m.tav.qu 'index:' m.idx.qu
end
/* build sql */
sql = 'select distinct p.collid, p.Name, p.version, p.type,' ,
"'vivo=' || p.validate || p.isolation ||" ,
"p.valid || p.operative ||" ,
"' con=' || hex(p.contoken) ||" ,
"' tst=' || char(p.timestamp) ," ,
" value((select count(*)",
"from sysibm.syspackage r",
"where r.location = p.location and r.collid = p.collid",
"and r.name = p.name",
"and r.timestamp > p.timestamp",
"and r.timestamp < current timestamp - 7 days),0)",
'from sysibm.syspackdep d join sysibm.syspackage p' ,
'on p.location = d.dLocation and p.collid = d.dCollid' ,
'and p.name = d.dName and p.conToken = d.dConToken' ,
'where'
do y=1 to m.obj.ow.0 /* add each qualifier */
qu = m.obj.ow.y
if m.tav.qu ^= '' then
sql=sql '( bQualifier =' qu 'and bName in ('m.tav.qu')) or'
end
if cntIdx <= 0 then do
sql = left(sql, length(sql) - 3)
end
else do /* subselect for tables of indexes */
sql=sql '( (bQualifier, bName) in' ,
'( select tbcreator, tbname' ,
'from sysibm.sysindexes where'
do y=1 to m.obj.ow.0
qu = m.obj.ow.y
if m.idx.qu ^= '' then
sql=sql '( creator =' qu 'and name in ('m.idx.qu')) or'
end
sql = left(sql, length(sql) - 3) ') )'
end
if m.debug then do /* debug generated sql */
l = 60
c = 1
do while length(sql) - c > l
do e = c+l by -1 while substr(sql, e, 1) ^== ' '
end
say substr(sql, c, e - c)
c = e + 1
end
say substr(sql, c)
end
return sql
endProcedure genSql
/*--- analyze the two parts of a qualified sql identifier ------------*/
anaQualIdent: procedure expose m.
parse arg s
if left(s, 1) = '"' then do
dx = pos('"', s, 2)
m.qual = substr(s, 2, dx - 2)
dx = dx + 1
end
else do
dx = pos('.', s)
m.qual = left(s, dx - 1)
end
if substr(s, dx+1, 1) = '"' then do
ex = pos('"', s, dx+2)
m.ident = substr(s, dx+2, ex - dx - 2)
end
else do
m.ident = substr(s, dx+ 1)
end
m.qual = "'"m.qual"'"
m.ident = "'"m.ident"'"
return m.qual
endProcedure anaQualIdent
/*--- detect the db2 subsystem ---------------------------------------*/
dbSubSys: procedure expose m.
parse arg a
/* subsys may be passed as argument */
if length(a) = 4 then
return a
else if length(a) = 2 then
return 'DB'a
else if length(a) = 1 then
return 'DB'a'F'
else if length(a) ^= 0 then
call errHelp 'bad abbreviation for db2 subsystem: "'a'"'
/* the db admin tool puts the name of the curren WSL library
in the variable ADBWLDSN in the shared pool,
however the session might be in a different split screen */
wslSubSys= ''
if ADRISP('VGET ADBWLDSN', '*') = 0 then do
if left(adbwldsn, 9) == "'DSN.DBA." ,
& substr(adbwldsn, 14) == ".WSL'" then
wslSubSys = substr(adbwldsn, 10, 4)
/* say 'db2SubSys' wslSubSys 'deduced from WSLLib' adbwldsn */
end
/* can we deduce the db2SubSys from the qualifiers? */
quaSubSys = ''
aa = ''
q = ''
do tyx=1 to words(m.types)
typ = word(m.types, tyx)
do x=1 to m.obj.typ.0
id = anaQualIdent(m.obj.typ.x)
upper m.qual
if pos(m.qual, aa) > 0 then
iterate
aa = aa m.qual
if substr(m.qual, 2, 3) = 'OA1' then
n = substr(m.qual, 5, 1)
else if substr(m.qual, 2, 3) = 'GDB' then
n = 'A'
else
iterate
/* compare new char with previous */
if q == '' then
q = n
else if q ^== n then
q = '*'
end
end
nd = sysvar(sysnode)
if length(q) = 1 & pos(q, 'ATZLP') > 0 then do
quaSubSys = 'DB'translate(q, 'O', 'P')'F'
if nd = 'RZ8' & quaSubSys = 'DBOF' then
quaSubSys = 'DD0G'
else if nd = 'RZZ' & quaSubSys = 'DBOF' then
quaSubSys = 'DE0G'
/* say 'db2SubSys' quaSubSys 'deduced from qualifiers:' aa */
end
/* compare what we got */
if wslSubSys <> '' then
if wslSubSys == quaSubSys | quaSubSys == '' then
return wslSubSys
else
call errHelp 'specify subsys because' wslSubSys,
'from WSLLib mismatches' quaSubsys 'from qualifiers ('aa')'
else if quaSubSys <> '' then
return quaSubSys
if nd = 'RZ2' | nd = 'RR2' then
return 'DBOF' /* here we have only one subsys | */
else if nd = 'RZ8' then
return 'DM0G' /* here we have only one subsys | */
else
call errHelp 'specify subsys.' ,
'Neither WSLLib nor qualifiers ('aa') do'
endProcecdure dbSubSys
/*--- delete comments and rebind statements
backward from given line and position cursor --------------*/
deleteRebindsUntil: procedure expose m.
parse arg origZl
/* scan backward over old rebind statements */
do lx = origZl by -1 to 1
call adrEdit '(li) = line' lx
w = word(li, 1)
if w = '' | left(w, 2) = '--' then
nop
else if translate(left(w, 6)) = 'REBIND' then
call cmp 'o', li
else
leave
end
/* scan forward over comments without rebind */
do lx = lx+1 by 1 to origZl
call adrEdit '(li) = line' lx
if li = '' | (left(word(li, 1), 2) = '--' ,
& pos('REBIND', translate(li)) < 1) then nop
else
leave
end
if lx < origZl then
call adrEdit 'delete' lx origZl
/* position cursor */
if lx < 10 then
lx = 2
call adrEdit 'locate' (lx-1)
return
endProcedure deleteRebinds
/*--- append 1 line at the end of the data ---------------------------*/
appLine: procedure expose m.
parse arg line
call adrEdit 'line_after .zl = (line)'
if word(line, 1) = 'REBIND' then
call cmp 'n' , line
return
endProcedure appLine
/*--- compare rebind statements --------------------------------------*/
cmp: procedure expose m.
parse arg typ, line
line = strip(line)
do x=1 to m.cmp.0
if m.cmp.x = line then do
m.cmpTyp.x = m.cmpTyp.x || typ
return
end
end
m.cmp.0 = x
m.cmp.x = line
m.cmpTyp.x = typ
return
endProcedure cmp
/*--- print compare rebind statements --------------------------------*/
cmpPrint: procedure expose m.
parse arg typ, line
eq = 0
nw = 0
od = 0
un = 0
do x=1 to m.cmp.0
if m.cmpTyp.x = 'no' | m.cmpTyp.x = 'on' then do
m.cmpTyp.x = '='
eq = eq + 1
end
else if m.cmpTyp.x = 'n' then
nw = nw + 1
else if m.cmpTyp.x = 'o' then
od = od + 1
else
un = un + 1
end
call appLine '---- compare' eq '=,' nw 'new,' od 'old,' ,
un 'others, total' m.cmp.0
do x=1 to m.cmp.0
call appLine '--'left(m.cmpTyp.x, 5)m.cmp.x
end
return
endProcedure cmpPrint
/***********************************************************************
scanning sql
***********************************************************************/
/*--- scan a qualified sql identifier --------------------------------*/
sqlQuId: procedure expose m.
parse arg mr
if \ scanSqlQuId(scanSkip(mr)) then
return ''
return m.mr.val
endProcedure sqlQualId
/*--- scan a sql identifier e.g. abc or "efg" ------------------------*/
sqlDeId: procedure expose m.
parse arg mr
if \ scanSqlDeId(scanSkip(mr)) then
return ''
return m.mr.val
endProcedure sqlDeId
/*--- scan a name after skipping over space and newLines -------------*/
sqlId: procedure expose m.
parse arg mr
if \ scanSqlId(scanSkip(mr)) then
return ''
return m.mr.val
endProcedure sqlId
/***********************************************************************
interface to scan - use edit data as scanner input
***********************************************************************/
/*--- error handling -------------------------------------------------*/
/* 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.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
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 scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- 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, onlyIfMatch
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
if onlyIfMatch == 1 then
nx = m.m.pos
else
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 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- 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
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
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
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
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.rdr \== '' then
interpret 'res = ' objMet(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.rdr \== '' then
interpret 'return' objMet(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.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
call classNew "n EditRead u JRW", "m",
, "jRead return editRead(m, var)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m, var
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) ^= 0 then
return 0
m.var = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 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 jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead 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 scanReadIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m, arg(3) ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
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 m
endProcedure scanWinOpts
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
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.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
parse arg m
m.m.atEnd = 'still closed'
call jClose m.m.rdr
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.rdr, 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
call scanWinRead m
if scanVerify(m, ' ') then do
res = 1
iterate
end
else if scanLit(m, '/*') then do
ex = pos('*/', m.m.src, m.m.pos+2)
if ex <= m.m.pos then
return scanErr(m, '*/ missing after /*')
m.m.pos = ex+2
res = 1
end
else do
cl = length(m.m.scanComment)
np = scanWinNlPos(m)
if \ ( cl>0 & m.m.pos+cl <= np & m.m.scanComment ,
== substr(m.m.src, m.m.pos, cl)) then
return res
m.m.pos = np
res = 1
end
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 '\n'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 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, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
endProcedure scanSqlReset
/*--- scan a sql token put class in m.sqlclass:
'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 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = '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.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' 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
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
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
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlStmt: procedure expose m.
parse arg m, delim
if delim == '' then
delim = ';'
res = ''
vChrs = strip('''"/'delim || left(m.m.scanComment, 1))
do forever
if scanSpaceNl(m) then
if right(res, 1) \== ' ' then
res = res' '
if scanVerify(m, vChrs, 'm') then
res = res || m.m.tok
else if scanString(m) then
res = res || m.m.tok
else if scanLit(m, delim) then do
m.m.val = res
return 1
end
else if scanChar(m, 1) then do
res = res || m.m.tok
end
else do
m.m.val = res
return res \= ''
end
end
endProcedure scanSqlStmt
/* copy scanSql end *************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
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'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
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
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
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 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
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
/*--- 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
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
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)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk, 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
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
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 = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()¢!'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, opt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = jCat1(m.line)
if \ abbrev(opt, '-', 1) then
do while jRead(m, line)
res = res || opt || m.line
end
else if opt == '-s' then
do while jRead(m, line)
res = res strip(m.line)
end
else if opt == '-72' then
do while jRead(m, line)
res = res || left(m.line, 72)
end
call jClose m
return res
endProcedure jCatLines
jCat1: procedure expose m.
parse arg v, opt
if \ abbrev(opt, '-', 1) then
return v
if opt == '-s' then
return strip(v)
if opt == '-72' then
return left(v, 72)
call err 'bad opt' opt 'in jCat1('v',' opt')'
endProcedure jCat1
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRWO', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
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
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), " ")')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat 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 || '.'
m.m.area.0 = 0
call mNewArea
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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.fileTso.buf = m.fileTso.buf + 1
m.m.defDD = 'CAT'm.fileTso.buf
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead 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 == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('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)
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
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 fileTsoClose
fileTsoRead: 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
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = mNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
interpret fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
COMMIT;
CREATE unique index vdps2.iixdu on VDPS2.DTUNDERFIXCOMQ
alter index vdps2.iixduZwei on VDPS2.DTUNDERFIXCOMQ
create lob tablespace a123 in db123
create synonym syefgh for own123.taefgh
CREATE TABLE VDPS2.DTUNDERFIXCOMP
alter table oa1a038.twk003a
alter table gdb9998.twk003a
commit sdf sdf; CREATE TABLE "VDPS3 "
. -- sdf sdf
-- sdf
"vdps table drei " ; create alias efg.hik
-s silent: remove members wi
kommentar vorher
-- generating rebinds in DBAF at 14:21:19 20/10/06 for F540769
-- for 1 tablespace, 5 table, 0 view, 2 index, 1 alias, 1 synonym
-- tablespace DB123.A123
-- table VDPS2.DTUNDERFIXCOMQ
-- table VDPS2.DTUNDERFIXCOMP
-- table "VDPS3 "."vdps table drei "
-- table OA1A038.TWK003A
-- table GDB9998.TWK003A
-- index VDPS2.IIXDU
-- index VDPS2.IIXDUZWEI
-- alias EFG.HIK
-- synonym OWN123.SYEFGH
REBIND PACKAGE(DB.DBWK2.(DB2J000003));
-- vivo=BSNY con=17EF4F701D8D1B72 tst=2006-09-29-14.38.38.590494
REBIND PACKAGE(DB.DBWK2.(DB2J000ABC));
-- vivo=BSNY con=17EF50AF1ACF23CB tst=2006-09-29-15.58.43.647758
REBIND PACKAGE(DB.DBWK2.(DB2J000XYZ));
-- vivo=BSNY con=17EF50B10BBC328C tst=2006-09-29-15.58.56.607691
REBIND TRIGGER PACKAGE(DGDB9998.WK003TRIG);
-- vivo=BSYY con=17ECF6B005DF3C90 tst=2006-09-14-16.52.20.179834
---- compare 4 =, 0 new, 0 old, 0 others, total 4
--= REBIND PACKAGE(DB.DBWK2.(DB2J000003));
--= REBIND PACKAGE(DB.DBWK2.(DB2J000ABC));
--= REBIND PACKAGE(DB.DBWK2.(DB2J000XYZ));
--= REBIND TRIGGER PACKAGE(DGDB9998.WK003TRIG);
}¢--- A540769.WK.REXX(DBARENA) cre=2009-11-10 mod=2009-11-10-14.36.39 A540769 ---
call sqlConnect DBOF
$=pds=DSN.DBA.ZUEGEL.NOV.RUN
call lmm $pds
$| $@for mbr $@¢
if \ datatype(substr($mbr, 2), 'n') then do
say 'ignoring' $mbr
iterate
end
call sqlPreAllCl 1, 'select changeid, name, status' ,
'from s100447.adbChg',
'where changeid =' substr($mbr, 2),
, cc, ':ch, :na, :sta'
if m.cc.0 = 0 then do
say $mbr 'not wsl found -> delete'
call adrTso "delete '"$pds"("$mbr")'"
end
else if m.cc.0 \= 1 then do
call err m.cc.0 'tupels for change' $mbr
end
else if sta == 'COMPLETE' then do
say $mbr 'delete wsl' ch na sta
call adrTso "delete '"$pds"("$mbr")'"
end
else do
neNa = strip(left(na, 8))
say $mbr ' renameTo' neNa 'for' ch 'named' na 'status' sta
call adrTso "rename '"$pds"("$mbr")' ("neNa")"
job = 'Y'left(neNa, 7)
call readDsn $pds'('neNa')', j.
jx = pos(' JOB ', j.1)
if jx < 1 | jx > 16 then
call err 'no jobCard in' neNa':' j.1
j.1 = '//'job strip(substr(j.1, jx))
call writeDsn $pds'('neNa')', j., , 1
end
$!
}¢--- A540769.WK.REXX(DBX) cre=2015-11-16 mod=2016-08-22-21.22.26 A540769 ------
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.2
23.06.16
edit macro fuer CS Nutzung von CA RCM
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr us naechsten Auftrag ab Tabelle erstellen
aa: anzueigen, aw, ac entsprechendes Member editieren
n,na,nc,nt neuen Auftrag erstellen (nt = test)
q dbSy? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren, sonst Alle
* funktioniert nicht nur in Auftrag
* dbSy hier wird gesucht sonst in source
c op1? create ddl from source
i | ia | ie subs nct changes in Db2Systeme importier(+ana+exe)
subs = sub(,sub)*: Liste von Stufen/rzDbSys
sub: RR2/DBOF (im PTA), RZY(betr. dbSy)
X, Y, Z, Q, R, P, UT, ST, SIT, IT Abkuerzungen
==> sucht im PromotionPath
nct: Nachtrag: leer=noch nicht importiert sonst angegeb
8: Nachtrag 8, *: neuster, =: wie letztes Mal
v* ¦ e* rzDb? nt?: view/edit ana,cdl,ddl,exe etc. locally or remote
* ist der llq oder Abkuerzung: a->ana, a1->an1
rzDb gibt rz und dbsys: rzz/de0g, ze, z, etc
nt Nachtrag, sucht neuest Import mit diesen Bedingunen
ren dbSy rename DSNs der Execution der Analyse in DBSystem
z 18? fun args fuer alle Auftraege / 18:00 Auftraege des ZglSchubs
zStat Zuegelschub Statistik siehe wiki help
opt* Optionale Optionen
-f force: ignoriere QualitaetsVerletzungen
oder dbx c im QualitaetsMember
-aAuft oder Auft: AuftragsMember oder DSN
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: vPT VP*, keeptgt 0, qCheck 0, dbaCheck 0, ddlOnly 1
dropAll
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
wiki help http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Dbx
************************************************************************
23. 6.2016 Walter dropAll und fix fuer DDLONLY (aber CA ...)
*/ /* end of help
10. 6.2016 Walter anaPost fuer ddlChange, DDK, PBG 4G
3. 6.2016 Walter mLem43, fix error fuer ren dbSy, uts2old
25. 4.2016 Walter utProfile for runstats profile, raus fuer ddlOnly
9. 2.2016 Walter support alias, view exeOut .....
19. 1.2016 Walter support sequence
19.11.2015 Walter remote edit, anaPre .......
8. 6.2015 Walter kidi63 ==> klem43
8. 9.2014 Walter warning falls ungueltiger ZS und kein update tadm70
29. 8.2014 Walter RQ2 rein, RZ1 raus
14. 7.2014 Walter zstat in rq2
26. 5.2014 Walter dbx q: auch TS mit History Tabellen anzeigen
17. 3.2014 Walter zstat: zuegelschub Datum korrigiert
18. 2.2014 Walter Integration in auftragsTable
23.12.2013 Walter dbx q findet tables mit type<>T, wieder csm.div
4.12.2013 Walter zStat macht nur Warnung wenn ana <> auftrag
25.10.2013 Walter move rz8 --> rzx
2.10.2013 Walter rename Analysis in ZielRz nicht RZ4 wegen Release
27. 9.2013 Walter move to rz4
26. 9.2013 Walter promotePaths UT,ST,SIT,x,y,z, nachtrag *
23. 9.2013 Walter vp0/1/2/3/4/16/17 + vp0=default
16. 9.2013 Walter Nachtraege in zSTat geflickt
2. 9.2013 Walter ueberall class=log (auch PTA|)
30. 8.2013 Walter vP17 fuer CA Tool Version 17
19. 8.2013 Walter zstat in rz4
9. 8.2013 Walter schenv pro rz in JobCard generiert
19. 7.2013 Walter qualityCheck fuer VW, kein Check wenn keine Objs
8. 7.2013 Walter zStat auch im RR2
28. 6.2013 Walter fix qualityCheck fuer Db
26. 6.2013 Walter dbx c in QualitaetsMember fuer Weiterarbeit ohne -f
25. 6.2013 Walter v2.4: zSta, Namen angepasst auf ca ...
11. 6.2013 W. Keller qualityCheck mit Verglich in RZ2 und vq
14. 5.2013 W. Keller VPT für tool Alias PT
07. 5.2013 W. Keller crLib with primary 1000 cyls (avoid alloc err)
03. 4.2013 W. Keller IA erstellt jetzt exeJcl in dsn.dbx<dbSys>.exe
07. 3.2013 W. Keller in neuem Auftrag: CA und VDPS Warnung
06. 2.2013 W. Keller ca scope fuer Triggers
31. 1.2013 W. Keller integration anaPost und start, variable auf7
24. 1.2013 W. Keller initial edit macro AC fuer CA Analysen
18. 1.2013 W. Keller caDdl->ddl, caGlbChg->glbChg ohne dbxRen.*
9. 1.2013 W. Keller ddlOnly fuer CA eingebaut
8.01.2013 W. Keller rename fuer CA eingebaut: dbx ni030121 ren dbaf
13.12.2012 W. Keller Fehler bei 1 stellig import (verwechslung nachtr)
7.12.2012 W. Keller .stry -> .ana, vy -> va etc.
5.12.2012 W. Keller ca implementation I
9.11.2012 W. Keller ey und vy für view/edit strategy
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset hi
/* call jIni ?????? */
call utIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.aTb = 'oa1p.tAdm70A1'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if 0 & oArgs = '' then do
oArgs = 'count ~tmp.text(qx010011)'
say 'testing' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
m.e.toolAlias = 'P0'
do forever
r = substr(fun, 1 + 2*abbrev(fun, '-'))
if abbrev(fun, '-A') | length(fun) >= 8 then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then
m.auftrag.force = 1
else if abbrev(fun, '-') then
call err 'bad opt' fun 'in' wArgs
else
leave
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
call mapPut e, 'rexxLib', 'DSN.DB2.EXEC'
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
if 0 then do /* ??? testSkels */
m.libSkels = 'DSN.DBX.V32skels(dbx'
call mapPut e, 'rexxLib', 'DSN.DBX.V32REXX'
say left('test v32' m.libSkels',' mapGet(e, 'rexxLib'), 78,'*')
end
if 0 & userid() = 'A540769' then do /* testSkels */
m.libSkels = 'A540769.wk.skels(dbx'
call mapPut e, 'rexxLib', 'A540769.WK.REXX'
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test' m.libSkels mapGet(e, 'rexxLib') '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
call mapPut e, 'tst', date('s') time()
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if fun == 'Z' then
return zglSchub(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if fun = 'COUNT' then
return countAna(args)
if wordPos(fun, 'AA NC NW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if wordPos(fun, 'AC AW') > 0 then
return nextAuftragFromATb(word(args, 1),
, substr(fun, 2), word(args, 2))
else if fun = 'C' & m.editMacro,
& right(m.edit.dataset, 8) = '.QUALITY' then
return qualityOk(fun, args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
else if fun = 'CPDUM' then
return cpDum(args)
else if fun = 'CRLIB' then
return crLib(args)
else if fun = 'REN' then
return renExeDsns(m.auftrag.member, args)
else if fun = 'ZSTAT' then
return zStat(args)
call memberOpt
if m.sysRz <> 'RZ4' then
call err 'dbx laeuft nur noch im RZ4'
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if abbrev(fun, 'E') | abbrev(fun, 'V') then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
ii = 'Marc ma'
else if m.uId = 'A390880' then
ii = 'Martin sm'
else if m.uId = 'A540769' then
ii = 'Walter wk'
else if m.uId = 'A754048' then
ii = 'Alessandro ac'
else if m.uId = 'A790472' then
ii = 'Agnes as'
else if m.uId = 'A828386' then
ii = 'Reni rs'
else if m.uId = 'A586114' then
ii = 'Stephan sz'
else if m.uId = 'F267248' then
ii = 'Caspar cr'
else
ii = m.uId '??'
parse var ii m.uNa m.uII
m.e.toolVers = ''
m.scopeTypes = 'DB TS TB VW AL IS IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths neu */
m.promN = 'X Y Z Q R P'
m.promN_A = 'UT ST SI SIT ET IT PQ PA PR'
m.promN_T = 'X Y Z,Q Z,Q X Y,Z,Q Q R P'
m.promD.1 = 'RZX/DE0G RZY/DE0G RZZ/DE0G' ,
'RQ2/DBOF RR2/DBOF RZ2/DBOF'
m.promD.2 = 'RZX/DEVG RZY/DEVG RZZ/DEVG' ,
'RQ2/DVBP RR2/DVBP RZ2/DVBP'
m.promD.0 = 2
/* promI columns in auftragsTable aTb */
m.promI.0 = 0
call dbxI2 'UT RZX/DE0G DEVG UT_RZX_DE0G ID1'
call dbxI2 'ST RZY/DE0G DEVG ST_RZY_DE0G ID4'
call dbxI2 'SIT RZ1/DBTF DVTB SIT_RZ1_DBTF ID2'
call dbxI2 'SIT RZZ/DE0G DEVG SIT_RZZ_DE0G ID3'
call dbxI2 'PQA RQ2/DBOF DVBP PTA_RZQ_DBOF ID6'
call dbxI2 'PTA RR2/DBOF DVBP PTA_RR2_DBOF ID5'
call dbxI2 'PROD RZ2/DBOF DVBP PROD_RZ2_DBOF ID7'
m.lastSaidToolV = 'P0'
return
endProcedure dbxIni
dbxI2: procedure expose m.
px = m.promI.0 + 1
m.promI.0 = px
parse arg m.promI.px
parse arg e rzD1 d2 fDt fUs
m.promI.rzD1 = fDt fUs
rzD2 = left(rzD1, 4)d2
m.promI.rzD2 = fDt fUs
return
endProcedure dbxI2
/*--- create the necessary dbx libraries locally ---------------------*/
crLib: procedure expose m.
parse arg subs
rz = sysvar(sysnode)
call crLibCr 'DSN.DBX.AUFTRAG'
call crLibCr 'DSN.DBX.DDK'
call crLibCr 'DSN.DBX.DDL'
call crLibCr 'DSN.DBX.GLBCHG'
call crLibCr 'DSN.DBX.JCL'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call crLibCr 'DSN.DBX's1'.ANA'
call crLibCr 'DSN.DBX's1'.AN1'
call crLibCr 'DSN.DBX's1'.DDI'
call crLibCr 'DSN.DBX's1'.DD1'
call crLibCr 'DSN.DBX's1'.DD2'
call crLibCr 'DSN.DBX's1'.EXE'
call crLibCr 'DSN.DBX's1'.REC'
call crLibCr 'DSN.DBX's1'.RE1'
call crLibCr 'DSN.DBX's1'.RDL'
call crLibCr 'DSN.DBX's1'.AOPT'
call crLibCr 'DSN.DBX's1'.QUICK'
end
return 0
endProcedure crLib
crLibCr: procedure expose m.
parse arg lib
call dsnAlloc lib'(DUMMY) dd(l1)' ,
'::f mgmtClas(COM#A076) space(1000, 1000) cyl'
call tsoFree l1
return 0
endProcedure crLibCr
crLibRe: procedure expose m.
parse arg lib, old
if sysDsn("'"old"'") <> "OK" then
return crLibCr(lib)
call adrTso "rename '"old"' '"lib"'"
return 0
endProcedure crLibRe
/*--- create the necessary dbx libries in the specified rz -----------*/
cpDum: procedure expose m.
parse arg rz subs
call cpDum1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.AUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.CDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call cpDum1 rz, 'DSN.DBX.JCL(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.MASK(DUMMY)'
call cpDum1 rz, 'DSN.DBX.OVRCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
*/call cpDum1 rz, 'DSN.DBX.DDL(DUMMY)'
if rz = 'RZ1' then
call cpDum1 rz, 'DSN.DBX.RENAMDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.GLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call cpDum1 rz, 'DSN.DBX's1'.ANA(DUMMY)',
, 'DSN.DBXDBAF.ANA(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.REC(DUMMY)',
, 'DSN.DBXDBAF.REC(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.DDL(DUMMY)',
, 'DSN.DBXDBAF.DDL(DUMMY)'
end
return 0
endProcedure cpDum
cpDum1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???cpDum' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
endProcedure cpDum1
renExeDsns: procedure expose m.
parse arg ana, dbsy
if length(ana) <> 8 then
call errHelp 'bad analysis' ana 'for ren'
if length(dbsy) <> 4 then
call err 'bad dbSystem' dbSy 'for ren'
if ana = m.edit.member then do
call memberOpt
call analyseAuftrag
ana = overlay(m.e.nachtrag, ana, 8)
end
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
/*say 'y' ly 'l' last 'dsn' m.csi.cx */
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = m.ut_uc
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
return 0
endProcedure renExeDsns
/*--- die Konfiguration pro db2 dbSy -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, dbSy
call configureRZ rz
call configuredbSy rz, dbSy
return
endProcedure configureRZSub
configureDbSy: procedure expose m.
parse arg rz, dbSy
call mapPut e, 'subsys', dbSy
if rz = 'RZX' then
call mapPut e, 'location', 'CHROI00X'dbSy
else if rz = 'RZY' then
call mapPut e, 'location', 'CHROI00Y'dbSy
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'dbSy
else
call mapPut e, 'location', 'CHSKA000'dbSy
return
endProcedure configureDBSy
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.promD.1)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.promD.1, rx+4, 4)
call mapPut e, 'schenv', 'DB2ALL'
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rz = m.myRz then
call mapPut e, 'csmDD'
else
call mapPut e, 'csmDD', ",(SUBSYS=(CSM,'SYSTEM="rz"'))"
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PB')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', 'DB2@.'zz'.'px'.DSNLOAD'
if toolV \== '' then
m.e.toolVers = toolV
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* toolV = copies(m.e.toolVers, rz == 'RZ1') */
toolV = m.e.toolVers
toolRZAl = zz'.'if(toolV == '', 'P0', toolV)
if m.lastSaidToolV \== substr(toolRzAl, 5) then do
m.lastSaidToolV = substr(toolRzAl, 5)
say 'tool version unter Alias' toolRzAl,
if(substr(toolRzAl, 5) =='P0', '==> v16')
end
call mapPut e, 'capref', 'DSN.CADB2.'toolRzAl
call mapPut e, 'caload', 'DSN.CADB2.'toolRzAl'.CDBALOAD'
call mapPut e, 'cacr', DBX
if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'e}dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'e}Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt, ai
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ4' then
if m.myRz = 'RZ1' then
call err 'dbx wurde ins RZ4 gezuegelt'
else
call err 'Auftrag für RZ' rz 'muss aus RZ4 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if wordPos(make, 'C W') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn, ai
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if ai \== '' then do
call sqlUpdate 7, 'update' m.aTb "set workliste='"nn"'" ,
", chg='"make"'",
"where workliste='' and pid ='"m.ai.pid"'" ,
" and name ='"m.ai.name"'"
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
cChgs = 'ALLLALLL'
iChgs = 'QZ91S2T'
end
else do
ow = 'S100447'
cChgs = 'PROT'if(abbrev(auftName, 'XB'), 'DVBP', 'DBOF')
iChgs = 'DBOF$impNm'
end
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
if ai == '' then do
/* loops in 2015 and later ......
zglS = '20130208 20130510 20130809 20131108' ,
'20140214 20140509 20140808 20141114 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
*/ zglSchub = '---'
best = 'pid name tel'
end
else do
zglSchub = m.ai.einfuehrung m.ai.zuegelschub
best = strip(m.ai.pid) strip(m.ai.name)
end
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller ' best ,
, ' cChgs ' cChgs ,
, ' iChgs ' iChgs ,
, ' aUtil all' ,
, ' keepTgt 0 '
if abbrev(auftName, 'VV') | abbrev(auftName, 'VDPS') then
call mAdd auftrag ,
, ' * ---------- Achtung VDPS -------------------------|' ,
, ' * nach jeder Aenderung alle anderen aktuellen |' ,
, ' * VDPS Auftraege Comparen (= DDL akutalisieren) |'
call mAdd auftrag ,
, 'source RZX/DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%'
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- naechsten Auftrag aus Auftragstabelle --------------------------*/
nextAuftragFromATb: procedure expose m.
parse arg pre, make, srch
srch = '%'translate(strip(srch))'%'
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where workliste = '' and pid not like 'ADMI%' and (" ,
"translate(pid) like '"srch"'" ,
"or translate(name) like '"srch"')" , ai
if m.ai.0 = 1 then
ax = 1
else if m.ai.0 < 1 then
call err 'e}kein Auftrag like' srch 'gefunden'
else do forever
say m.ai.0 'auftraege like' srch
do ax=1 to m.ai.0
say ax m.ai.ax.pid m.ai.ax.name m.ai.ax.einfuehrung ,
m.ai.ax.zuegelschub
end
say 'welcher Auftrag? 1..'m.ai.0 'oder - fuer keinen'
parse pull ax .
if strip(ax) == '-' then
return ''
if verify(ax, '0123456789') = 0 & ax > 0 & ax <= m.ai.0 ,
& symbol('m.ai.ax.zuegelschub') == 'VAR' then
leave
say 'ungueltige Wahl:' ax
end
return nextAuftrag(pre, make, , 'AI.'ax)
endProcedure nextAuftragFromATb
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', m.e.auf7 || m.e.nachtrag
if m.e.qCheck == 0 then nop
else if m.sysRz \== 'RZ1' & m.sysRz \== 'RZ4' then
say 'no quality check from' m.sysRz
else do
qx = m.scopeSrc.rz'/'m.scopeSrc.dbSy
px = m.promPath
qy = word(m.promD.px, words(m.promD.px))
if qualityCheck(qx, qy) then do
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 0
call adrIsp 'vput' vAns 'shared'
ddlxP = substr(m.auftrag.member, 8, 1)
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
call adrIsp "view dataset('"qDsn"'),
macro(ddlX) parm(ddlxP)",4
call adrIsp 'vget' vAns 'shared'
if pos('F', opts) < 1 & \ m.auftrag.force ,
& value(vAns) \== 1 then
return
else
say 'Compare trotz Qualitaetsfehlern'
end
end
m.o.0 = 0
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.dbSy, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast m.e.auf7 || nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast m.e.auf7 || nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
call mapPut e, 'keepTgtV', copies('KEEPTGT,', m.e.keepTgt)
if m.e.tool == ca then
call caDDL o, scopeSrc, translate(mapExp(e, m.e.cChgs))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeSrc.rz'/'m.scopeSrc.dbSy ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat","DDL") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- in the qualityMember say dbx c
to continue processing without option -f ------------------*/
qualityOk: procedure expose m.
parse arg fun
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 1
call adrIsp 'vPut' vAns 'shared'
return 0
endProcedure qualityOk
/*--- find the naming convention for a rz and dbSystem --------------*/
namingConv: procedure expose m.
parse arg rz, dbSy, var
if rz = '.' then do
if pos('.', dbSy) > 0 then
call err 'namingConv old target' dbSy
if pos('/', dbSy) > 0 then
parse var dbSy rz '/' dbSy
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(dbSy)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', m.o.
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh . , a1 a2
call analyseAuftrag
if length(wh) > 2 then do
llq = wh
end
else do /* abbrev: first or first and last character */
ll = ' ANA AN1 AOPT DDL DDK DDI DD1 DD2 EXE EXO' ,
'JCL QUALITY QUICK REC RE1 RDL START'
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then do
d = '* .JCL' m.e.auftrag
end
else if llq == 'QUALITY' | LLQ == 'DDK' | llq = 'DDL' then do
d = '* .'llq m.e.auf7 || left(a1 || m.e.nachtrag, 1)
end
else if llq == 'EXO' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
msk = r2'/DSN.DBY'd2'.'m.e.auf7'*.**.EX*'
if dsnList(oo, msk, 0) < 1 then do
say 'no datasets like' msk
return
end
do ox=1 to m.oo.0
d1 = m.oo.ox
d2 = substr(d1, pos('.', d1, 19)+1)
if ox=1 | abbrev(d2, '##DT') ,
| (d2 > dMi2 & \ abbrev(dMi2, '##DT')) then do
dMax = d1
dMi2 = d2
end
end
d = r2 dMax
end
else if llq == 'START' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 'DSN.DBY'd2'.'m.e.auf7'.'llq
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 d2'.'llq m.e.auf7 || n2
end
parse var d rz dsn mbr
if length(dsn) <= 20 then
dsn = m.libPre || dsn
eFun = word('Edit View', 1 + (fun \== 'E'))
if llq = 'QUALITY' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wordPos(llq, 'ANA AN1 REC RE1 EXO') > 0 then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"dsn ,
|| copies("("mbr")", mbr<>'')"')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"dsn"')",
copies("member("mbr")", mbr <> '') mac, 4
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call addIfEndSet jOut
call addIfEndSet jOut'.TWO'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = a2rzDbSysProm(rzDbSyList)
done = ''
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' dbSy
if opt == '*' then do
nachAll = m.compares
end
else if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if fun = 'IE' & (r == 'RZ2' ,
| (r == 'RZ4' & \ (abbrev(m.e.auftrag, 'Q') ,
|abbrev(m.e.auftrag, '@E') ,
|abbrev(m.e.auftrag, 'WK')))) then
call err 'ie fuer Prod nicht erlaubt:' r'/'dbSy
if m.e.tool = 'CA' then
nachAll = right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
if trgNm = '' then
call err 'compare not found for nachtrag' nachAll
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelN8, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs
else
call mapPut e, 'change',m.e.auftrag':'nachAll'/' ,
|| m.imp.seq'_'zs
call mapPut e, 'change', chaPre'.'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rzDbSys
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', m.e.auf7 || right(nachAll, 1)
done = done rzDbSys
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureDbSy r, dbSy
if m.e.tool == 'CA' then
call caImport jOut, fun, nachAll,
, translate(mapExp(e, m.e.iChgs)),
, translate(mapExp(e, m.e.iMap)),
, translate(mapExp(e, m.e.iRule))
else
call ibmImport jOut, fun, r, dbSy, nachAll,
, translate(mapExp(e, m.e.impMask)),
, translate(mapExp(e, m.e.impIgno))
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fu2)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
call addJobError jOut
call writeSub jOut
sq = ''
if m.e.zuegelN8 \== '' then do
today = translate('78.56.1234', date('s'),'12345678')
do dx=1 to words(done)
d1 = word(done, dx)
if symbol('m.promI.d1') \== 'VAR' then
call warn 'no col for' d1 'in AuftragsTable' m.aTb
else
sq = sq"," word(m.promI.d1, 1) "= '"today"'," ,
word(m.promI.d1, 2) "= '"m.uII"'"
end
end
if sq == '' then do
call warn 'zuegelSchub='m.e.zuegelSchub ,
'kein update in AuftragsTabelle' m.aTb
end
else do
call sqlConnect m.myDbSys
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'"
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'not in table' m.aTb
else if m.sql.1.updateCount \== 1 then do
call sqlUpdate 99, 'rollback'
call err 'auftrag' m.e.auftrag 'got' ,
m.sql.1.updateCount 'updateCount'
end
call sqlCommit
call sqlDisconnect
end
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
toRz = m.myRz
call mapPut e, 'toRz', toRz
if m.o.send.0 \== 0 & m.sysRz \== toRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.toRz.c1 \== 1 then do
m.cdlSent.toRz.c1 = 1
if sAft == '' then do
call mapPut e, 'cdl', dsnSetMbr(c1)
eIf = addIf(o)
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIfEndSet o, eIf, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
endIf = addIf(o)
call mAddSt o, o'.TWO'
call addIfEndSet o, endIf, m.o.two.ifLine
end
else do
endIf = addIf(o)
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call addJobError o'.TWO'
call mAddSt o, o'.TWO'
call mAdd o, la
call addIfEndSet o, endIf, 'SUB'toRz
end
m.o.two.0 = 0
call addIfEndSet jOut'.TWO'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o'.SEND', c1
end
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TWO', nachAll
return
endProcedure ibmImport
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
endIf = addIf(o)
ic = skelStem('Imp')
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIfEndSet o, endIf, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddC.1 = 1
ddC.2 = 2
ddC.3 = 'I'
ddlIx = 3 - (iChgs \== '') - m.e.anapost
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib|| ddC.ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddC.ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddlBB
end
endIf = addIf(o'.TWO')
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly) ,
copies('dropAll', m.e.dropAll) ,
copies('keepTgt0', m.e.keepTgt == 0) ,
copies('anaPost0', m.e.anaPost == 0) ,
copies('uts2old', m.e.uts2old == 1)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIfEndSet o'.TWO', endIf, 'AOPT'
call mapPut e, 'stry', nact
call stepGroup
ddlImp = ddlLib'I('nact')'
if m.e.anaPost then do
call mapPut e, 'ddlIn', ddlAA
call mapPut e, 'ddlOut', ddlImp
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIfEndSet o'.TWO', endIf, 'PRE'
end
call mapPut e, 'ddlin', ddlImp
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIfEndSet o'.TWO', endIf, 'AUTO'
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
call stepGroup
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
if m.e.aUtil = '' | m.e.ddlOnly then
utProf = ''
else
utProf = m.e.aUtil || copies('RUN',
, wordPos(m.myRz, 'RZX RZY') > 0)
if utProf = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' utProf' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
if m.e.ddlOnly then
call mapPut e, 'ddlOnlyOrUnload', '' /*
errror in rc/m no control ......
call mapPut e, 'ddlOnlyOrUnload', 'DDLONLY' */
else
call mapPut e, 'ddlOnlyOrUnload', 'UNLOAD'
call mapPut e, 'dropAll', copies('DROPALL', m.e.dropALl)
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CAna')
if m.e.anapost then
call mapExpAll e, o'.TWO', skelStem('CPost')
call addIfEndSet o'.TWO', endIf,
, 'ANA', 0 4, copies('POST', m.e.anaPost)
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
endIf = addIf(o'.TWO')
oldIf = m.o.two.ifLine
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
call addIfEndSet o'.TWO'
call mapPut e, 'fun', 'execute'
call mapExpAll e, o'.TWO', skelStem(m.jobcard)
call mAdd o'.TWO', '//* Zuegelschub' m.e.zuegelschub k,
, '//* analyse ' date(s) time() m.uNa ,
, '//* nachtrag ' m.e.nachtrag m.e.auf7 || m.e.nachtrag,
, '//* rename old unloads: TSO DBX' m.e.auf7||m.e.nachtrag,
"REN" mapGet(e, 'subsys')
call caExecute o'.TWO'
call mAdd o'.TWO', '}!'
m.o.two.ifLine = oldIf
call stepGroup old
call addIfEndSet o'.TWO', endIf, 'EXCP', 0 4
end
else if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
if m.e.anapost then do
endIf = addIf(o)
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIfEndSet o, endIf, 'DDL', 0 4
call mapPut e, 'rdlArc', pre'.RDL('nact')'
end
else do
call mapPut e, 'rdlArc', ''
end
endIf = addIf(o)
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
call addIfEndSet o, endIf, 'EXE', 0 4
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
endIf = addIf(o)
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o, '// ENDIF' /* for unterminated if in cRen */
call addIfEndSet o, endIf, 'RANA', 0 4
return
endProcedure caImpRename
stepGroup: procedure expose m.
parse arg f
old = m.e.stepNo
if f \== '' then
no = f
else
no = old + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return old
endProcedure stepGroup
addIfEndSet: procedure expose m.
parse arg o, endIf, stp, codes
if endIf \== '' then
call mAdd o, endIf
if stp == '' | m.e.tool = 'IBM' then
m.o.ifLine = ''
else if words(stp) > 1 then
m.o.ifLine = stp
else do
li = ''
do ax=3 by 2 to arg() while arg(ax) \== ''
stp = arg(ax)
codes = arg(ax+1)
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = li 'AND' stp'.RUN AND'
if codes == '' then
li = li stp'.RC=0'
else if words(codes) = 1 then
li = li stp'.RC='strip(codes)
else do
li = li '('stp'.RC='word(codes, 1)
do cx=2 to words(codes)
li = li 'OR' stp'.RC='word(codes,cx)
end
li = li')'
end
end
m.o.ifLine = substr(li, 6)
end
return
endProcedure addIfEndSet
addIf: procedure expose m.
parse arg o, opt
if symbol('m.addIfCnt') \== 'VAR' then
m.addIfCnt = 1
else
m.addIfCnt = m.addIfCnt + 1
if m.o.ifLine == '' then
return ''
pr = left('//IF'm.addIfCnt, 9)'IF'
cond = space(m.o.ifLine, 1)
do while length(cond) > 53
ex = lastPos(' ', left(cond, 53))
call mAdd o, pr left(cond, ex-1)
cond = substr(cond, ex+1)
pr = left('//', length(pr))
end
call mAdd o, pr cond 'THEN'
return '// ENDIF IF'm.addIfCnt
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if m.o.ifLine = '' then
m.o.ifLine = 'ABEND OR RC <> 0'
else
m.o.ifLine = 'ABEND OR RC > 4 OR NOT (' m.o.ifLine ')'
endIf = addIf(o)
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, endIf
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.anaPost = 1
m.e.ddlOnly = 0
m.e.dropAll = 0
m.e.uts2old = 0
m.e.zuegelschub = ''
m.e.aOpt = ''
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER ICHGS IMPMASK IMAP IRULE IMPIGNO'
varWu = 'CCHGS COMMASK COMIGNO' ,
'AOPT AMODEL AUTIL VP0 VP1 VP2 VP3 VP4 VPT UTS2OLD' ,
'KEEPTGT DBACHECK QCHECK CA DDLONLY DROPALL ANAPOST'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.auf7 = left(w2, 7)
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.e.anaPost = m.e.anaPost == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
m.e.ddlOnly = m.e.ddlOnly == '' | m.e.ddlOnly == 1
m.e.dropAll = m.e.dropAll == '' | m.e.dropAll == 1
if m.e.cChgs == '' then
m.e.cChgs = 'PROT'm.e.prodDbSys
if m.e.iChgs == '' then
m.e.iChgs = dsnGetMbr(m.e.impMask)
else if m.e.impMask == '' then
m.e.impMask = m.libPre'.MASK('m.e.iChgs')'
if m.e.iRule == '' then
m.e.iRule = dsnGetMbr(m.e.impIgno)
else if m.e.impIgno == '' then
m.e.impIgno = m.libPre'.MASK('m.e.iRule')'
call mapPut e, 'aModel', m.e.aModel
zt = translate(m.e.zuegelschub, '000000000', '123456789')
if zt == '00.00.0000' then do
m.e.zuegelN8 = translate('67893401', m.e.zuegelSchub,
,'0123456789')
end
else if zt == '00000000' then do
m.e.zuegelN8 = m.e.zuegelSchub
m.e.zuegelschub = translate('78.56.1234', m.e.zuegelN8,
,'12345678')
end
else do
m.e.zuegelN8 = ''
end
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.dbSy, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop dbSy
say ' scope ' m.scp.0 m.scp.dbSy ,
' target ' m.scopeTrg.0 m.scopeTrg.dbSy
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
sayImp: procedure expose m.
do ix=1 to m.imp.0
say 'imp' m.imp.ix.nachtrag 'to' m.imp.ix.rz'/'m.imp.ix.dbSys
end
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureDbSy m.scopeTrg.rz, m.scopeTrg.dbSy
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- create jcl to copy one member to rz toRz and library toLib -----*/
copyMbr: procedure expose m.
parse arg o, mbr, frLib, toRz, toLib
call mapPut e, 'mbr', mbr
call mapPut e, 'frLib', dsnSetMbr(frLib)
call mapPut e, 'toRz', toRz
call mapPut e, 'toLib', dsnSetMbr(toLib)
endIf = addIf(o)
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIfEndSet o, endIf, 'COPY', 0
return
endProcedure copyMbr
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlConnect m.scp.dbSy
else
call sqlConnect m.scp.rz'/'m.scp.dbSy
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
trace ?r
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
removeQualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure removeQualityCheck
/*--- Qualitaets Pruefung mittels ddlCheck ---------------------------*/
qualityCheck: procedure expose m.
parse arg x, y
m.spezialFall.done = ''
lst = ''
scp = 'SCOPESRC'
o = 'AUFTRAG'
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then
f1 = 'db:'m.sn.name
else if m.sn.Type = 'TS' then
f1 = 'ts:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'TB' then
f1 = 't:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'VW' then
f1 = 'v:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'IX' then
f1 = 'i:'m.sn.qual'.'m.sn.name
else
iterate
f1 = space(f1, 0)
if wordPos(f1, lst) > 0 then
iterate
lst = lst f1
end
m.o.orig = 'rmQu' m.o.orig
if lst = '' then do
say 'qualitycheck no objects to check'
call mAdd o, '|| qualitycheck no objects to check'
return 0
end
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
cRes = ddlChQ('CHECK' qDsn x y lst)
call splitNl cr, cRes
cr1 = substr(m.cr.1, 4)','
if pos('\n', cRes) > 0 then
cr1 = left(cRes, pos('\n', cRes)-1)','
else
cr1 = cRes','
res = pos('q,', cr1) > 0 | pos('*sb,', cr1) > 0 ,
| pos('*p', cr1) > 0 | pos('*n,', cr1) > 0 ,
| pos('special', cr1) > 0 | pos('*-,', cr1) > 0
if \ res then do /* add new | lines to auftrag */
call mAdd o, '|| qualitycheck ok:' substr(m.cr.1, 4)
end
else do
call mAdd o, '|| qualitycheck:' substr(m.cr.1, 4)
call mAddSt o, cr, 2
end
return res
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
removeSspezialFall: procedure expose m. --> ddlCheck
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-' left(m.st.sx, 78)
end
return
endProcedure removeSpezialFall
/*--- mask handling initialise ---------------------------------------*/
removemaskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
removemaskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
removetestMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
removeMaskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
removemask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
removemaskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
removemaskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
removemaskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg dbSy
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & dbSy == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if dbSy = '' then
dbSy = if(subs2 == '', m.pr1Sub, subs2)
dbSy = translate(dbSy, '/', '.')
if abbrev(dbSy, m.sysRz'/') then
dbSy = substr(dbSy, 5)
call sqlConnect dbSy
dbSy = translate(dbSy, m.ut_lc, m.ut_uc)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu dbSy) < 70 then
neu = left(neu, 68 - length(dbSy)) '*'dbSy
else if length(neu dbSy) < 80 then
neu = neu '*'dbSy
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(name)," ,
"case when nTables <> 1",
"then 'ty=' || type" ,
"|| ', ' || nTables || ' tables||| '",
"else value( (select 'tb '" ,
"|| strip(t.creator) ||'.'|| strip(t.name)",
"|| case when t.type = 'T' then ''" ,
"else ' ty=' || t.type end" ,
"from sysibm.systables t" ,
"where t.type not in ('A','V')" ,
"and t.dbName=s.dbName and t.tsName=s.name" ,
"), 'not found')" ,
"end" ,
"from sysibm.systableSpace s" ,
"where dbName" sqlClause(qu) "and name" sqlClause(nm)
/*???else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end" ,
"|| min(strip(creator) ||'.'|| strip(name))",
"|| case when count(*) = 1 and min(type) <> 'T'" ,
"then ' ty=' || min(type) else '' end" ,
"from sysibm.systables" ,
"where type not in ('A','V')" ,
"and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName" ???????????*/
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case type when 'V' then 'vw'",
"when 'A' then 'al' else 'tb' end," ,
"strip(creator) || '.' || strip(name)" ,
"|| case when type <> '"left(ty, 1)"'" ,
"then ' ty=' || type else '' end," ,
"case when type = 'A' then 'for '" ,
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type" if(ty=='TB', "not in ('A', 'V')" ,
, "= '"left(ty, 1)"'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IS' then
sql = "select 'is', strip(dbName) ||'.'|| strip(indexSpace),",
"'tb ' || strip(tbCreator)|| '.' || strip(tbName)" ,
" || ' ix ' || strip(name)" ,
'from sysibm.sysIndexes' ,
'where dbname' sqlClause(qu),
'and indexSpace' sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', 'FT FN FI'
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = m.e.auf7 || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
if m.e.anaPost then
oDsn = mapExp(e, '${libPre}.DDK($mbrNac)')
else
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
call addIfEndSet o, , ddl, 0 4
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' oDsn)
call caDD1 o, scp, GlbChg, oDsn
call sendJob2 o, sndIn, cf mark
call addIfEndSet o, , 'RECSRC'
end
if m.e.anaPost then do
endif = addIf(o)
call mapExpAll e, o, skelStem('CDDPO')
call addIfEndSet o, endIf
end
return 0
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg, ddlOut
call mapPut e, 'user', userid()
call mapPut e, 'ddlOut', ddlOut
call mapExpAll e, o, skelStem('CCOM')
call mapPut e, 'comm', mapExp(e, 'dbx $fun',
copies('recover', pos('.RDL(', ddlOut) > 0)'DDL' ,
'$AUFTRAG $NACHTRAG')
if abbrev(scp, '//') then
call mAdd o, scp, '// DD *'
else do sx=1 to m.scp.0
call rcmQuickAdd o, m.scp.sx.type, m.scp.sx.qual, m.scp.sx.name
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".GlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V SQ' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V SQ' , 'EXPLODE ROUTINE'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'ALIAS' , 'A AL'
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
call rcmQuickTyp1 'SEQUENCE ', 'SQ Q'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.dbSy \== m.scopeTrg.dbSy then
call err 'bmc compare on different dbSystems not implemented'
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlConnect m.scp.dbSy
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
zglSchub: procedure expose m.
parse arg fun rest
if length(fun) = 4 & datatype(fun, 'n') then
parse arg zgl fun rest
else
zgl = substr(date('s'), 3, 4)
only18 = fun == 18
if only18 then
parse var rest fun rest
if fun = '' then
call err 'zglSchub kein Fun fuer Auftraege:' arg(1)
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
copies("and einfuehrungs_zeit = '18:00'", only18) , zsa
call sqlDisconnect
do zx=1 to m.zsa.0
if m.zsa.zx.workliste = '' then
iterate
say zx m.zsa.zx.workliste m.zsa.zx.auftrag ,
m.zsa.zx.einfuehrungs_zeit m.zsa.zx.id7
call work m.zsa.zx.workliste fun rest
end
endProcedure zglSchub
/*--- zStat Zuegelschub Statistik ------------------------------------*/
zstat a? yymm? - in rz4, create AyyMM mit AuftragsListe
----------------------------------------------------------------------*/
zStat: procedure expose m.
parse upper arg aArg
parse upper arg fun zgl
rz = sysvar('sysNode')
if fun = '' then
if rz = 'RZ4' then
fun = 'A'
else if rz = 'RZ2' | rz = 'RR2' | rz = 'RQ2' then
fun = 'S'
z0 = translate(zgl, '000000000', '123456789')
if zgl = '' then
z1 = substr(date('s'), 3, 4)
else if z0 == '0000' then
z1 = zgl
else if z0 == '000000' then
z1 = substr(zgl, 3)
else if z0 == '00.00.00' then
z1 = translate('5634', zgl, '12.34.56')
else
call err 'bad Zugelschub should be yymm or dd.nn.yy not' zgl
aDsn = m.libPre'.ZGL(ZSTA'z1')'
sDsn = m.libpre'.ZGL(ZSTS'z1')'
if fun = 'A' then do
if rz <> 'RZ4' then
call err 'zstat a... only in rz4'
if sysDsn("'"aDsn"'") == 'OK' then
call err "e}"aDsn "existiert schon"
call zStatAuftragsListe z1, m.libPre'.auftrag', aDsn
end
else if fun == 'S' then do
if rz <> 'RZ2' & rz <> 'RR2' & rz <> 'RQ2' & rz <> 'RZ4' then
call err 'zstat s... only in rz2 or rz4'
if sysDsn("'"aDsn"'") \== 'OK' then
call err aDsn "existiert nicht"
call zStatsStatistik z1, aDsn, sDsn
end
else
call err 'i}bad fun' fun 'in arguments zStat' aArg
return 0
endProcedure zStat
zStatAuftragsListe: procedure expose m.
parse arg zgl, lib, outDsn
zg2 = '20'zgl
zg3 = translate('.34.12', zgl, '1234')
zg4 = translate('.cd.20ab', zgl, 'abcd')
call sqlConnect m.myDbSys
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
/* copy ii end ********* Installation Info *************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
m.m.0 = mx
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
m.m.0 = mbr_name.0
end
return mx
endProcedure mbrList
/*--- return wheter a dsn exists ------------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
----------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse arg fr, to, mbrs
if mbrs \== '' then do
if dsnGetMbr(fr) \== '' | dsnGetMbr(to) \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if words(mbrs) == 1 then do
parse value strip(mbrs) with old '>' new
if old = '' then
call err 'bad mbr old/new' mbrs
fr = dsnSetMbr(fr, old)
to = dsnSetMbr(to, word(new old, 1))
mbrs = ''
end
end
/* currently we do everything with csm
if the need arises, implement tso only version */
return csmCopy(fr, to, mbrs)
endProcedure dsnCopy
dsnDelete: procedure expose m.
parse arg aDsn
parse value dsnCsmSys(aDsn) with sys '/' dsn
if sys \== '*' then
return csmDel(sys, dsn)
if adrTso("delete '"dsn"'", 8) == 0 then
return 0
if pos('IDC3330I **' dsnGetMbr(dsn)' ', m.tso_trap) >= 1 then
say 'member not found and not deleted:' dsn
else if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then
say 'dsn not found and not deleted:' dsn
else
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDelete
/* copy dsnList end ************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn
if dsnGetMbr(dsn) == '' then do
if adrCsm("allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)", 8) == 0 then do
call adrTso 'free dd(del1)'
return 0
end
if pos('CSMSV29E DATA SET' dsn 'NOT IN CAT', m.tso_trap) > 0,
then do
say 'dsn not found and not deleted:' rz'/'dsn
return 4
end
end
else do
if adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8) == 0 then
return 0
if pos('CSMEX77E Member:'dsnGetMbr(dsn) 'not f', m.tso_trap) ,
> 0 then do
say 'member not found and not deleted:' rz'/'dsn
return 4
end
end
return err('csmDel rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(fr) \== ''
toMbr = dsnGetMbr(to) \== ''
call csmAlloc fr, frDD, 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
/*??if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr) ???????? */
call csmAlloc to, toDD, 'shr', , ':D'frDD
/* if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end ?????????????? */
inDD = tsoDD('csmIn*', 'a')
i.0 = 0
if mbrs \== '' then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
else if \ frMbr & m.tso_dsOrg.frDD == 'PO' then do
call adrCsm "mbrList ddName("frDD") index(' ') short"
i.0 = mbr_mem#
do ix=1 to i.0
i.ix = ' S M='mbr_name.ix
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*"
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do /* copy output to stem */
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead return sqlRdrRead(m)")
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead return sqlRdrRead(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
return sqlsOut(scanSqlStmtRdr(sqlSrc, opt), retOk, 'a')
endProcedure sqlStmts
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrRead: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrRead
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then
return err('??? old interface') / 0
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
m.m.bufI0 = m.m.bufI0 + m.m.buf.0
m.m.readIx = 0
interpret objMet(m, 'jRead')
ix = 1
if m.m.buf.0 < ix then
return err('jRead but no lines') / 0
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
interpret objMet(m, 'jWrite')
return
endProcedure jWrite
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.bufMax = 0
return m
endProcedure jReset
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
call jReset0 m, arg, arg2, arg3
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
/*--- text for a method, for buffer of size 1 only ------------------*/
jWrite1Met: procedure expose m.
parse arg f1
return "jWrite if m.m.buf.0\==1 then call err 'bad jWrite1Met';" ,
"var = m'.BUF.1'; m.m.buf.0 = 0;" f1
/*--- text for a method, for buffer
jWriteBMet: procedure expose m.
parse arg f1, fe
return "jWrite" ,
copies("do wx=1 to m.m.buf.0;" ,
"var = m'.BUF.'wx;" f1"; end;", f1 <> '') ,
copies("vBu = m'.BUF';" fe";", fe <> ''),
"m.m.bufI0 = m.m.bufI0 + m.m.buf.0; m.m.buf.0 = 0"
------------------*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "new return 'm = jReset0('classMet(cl, 'new2')');'" ,
"classMet(cl, 'jReset')'; return m'" )
/* "new ?r m = jReset0(?new2); ?jReset; return m" */
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
cDe= classNew('n JRWDelegLazy u LazyRoot', 'm',
, "new return 'return jReset('classMet(cl, 'new1')', arg)'" )
/* , "new ?r return jReset(?new1, arg)", */
c2 = classNew('n JRWDeleg u JRW', 'm',
, "METHODLAZY" cDe,
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, jWrite1Met(" say o2Text(m.var, 157)"),
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose" ,
, "jRead return 0",
, "jWrite call err 'buf overflow",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
call classNew "n JbufText u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = word(arg 80, 1)",
, "jWrite call jBufWrite m, o2Text(line, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jBufText: write text descriptions -----------------------------*/
jbufText: procedure expose m.
m = oNew('JbufText') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = o2text(arg(ax))
end
m.m.buf.0 = ax-1
return m
endProcedure jbufText
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
m.m.bufMax = 1e30
if opt == m.j.cWri then do
m.m.buf.0 = 0
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
m.m.buf.0 = ax
return m
endProcedure jBufWriteStem
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.s2c., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj ---------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
r = m'=¢'
do fx=1 to m.cl.flds.0 while length(r) <= maxL
f1 = m.cl.flds.fx
c1 = m.cl.f2c.f1
if c1 = m.class_V then
op = '='
else if m.c1 == 'r' then
op = '=>'
else
op = '=?'c1'?'
r = r || left(' ', fx > 1) || m.cl.flds.fx || op
if m.cl.flds.fx == '' then
r = r || strip(m.m)
else
r = r || strip(mGet(m'.'m.cl.flds.fx))
end
if length(r) < maxL then
return r'!'
else
return left(r, maxL-3)'...'
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, met
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
return 'return o2TextFlds(m, '''cl''', maxL)'
endProcedure o2TextGen
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "o2Text return o2textGen(cl)",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new return 'return' classMet(cl, 'new2')",
, "new1 call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'oMutate(mNew('''cl'''), '''cl''')'" ,
, "new2 call classMet cl, 'oClear';" ,
"return 'classClear('''cl''','" ,
"classMet(cl, 'new1')')'" ,
, "oClear return classClearGen(cl)" ,
, "oCopy return oCopyGen(cl)")
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
/* 'o2Text ?r return m"=¢?:!"' */
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, 'o2String return m')
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
laRun = classNew('n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''")
/* 'o2Text ?r return m"=¢?:!"' */
call classNew 'n ORun u', 'm',
, 'METHODLAZY' laRun ,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively -------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldGen: procedure expose m.
parse arg cl
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
classClearGen: procedure expose m.
parse arg cl
call classMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
dProcedure classClearGen
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
dd = tsoDD(dd, 'a')
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBXAA) cre=2014-12-16 mod=2016-01-14-08.24.08 A540769 ----
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.1
13.01.16
edit macro fuer CS Nutzung von CA RCM
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr us naechsten Auftrag ab Tabelle erstellen
aa: anzueigen, aw, ac entsprechendes Member editieren
n,na,nc,nt neuen Auftrag erstellen (nt = test)
q dbSy? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren, sonst Alle
* funktioniert nicht nur in Auftrag
* dbSy hier wird gesucht sonst in source
c op1? create ddl from source
i | ia | ie subs nct changes in Db2Systeme importier(+ana+exe)
subs = sub(,sub)*: Liste von Stufen/rzDbSys
sub: RR2/DBOF (im PTA), RZY(betr. dbSy)
X, Y, Z, Q, R, P, UT, ST, SIT, IT Abkuerzungen
==> sucht im PromotionPath
nct: Nachtrag: leer=noch nicht importiert sonst angegeb
8: Nachtrag 8, *: neuster, =: wie letztes Mal
v* ¦ e* rzDb? nt?: view/edit ana,cdl,ddl,exe etc. locally or remote
* ist der llq oder Abkuerzung: a->ana, a1->an1
rzDb gibt rz und dbsys: rzz/de0g, ze, z, etc
nt Nachtrag, sucht neuest Import mit diesen Bedingunen
ren dbSy rename DSNs der Execution der Analyse in DBSystem
z 18? fun args fuer alle Auftraege / 18:00 Auftraege des ZglSchubs
zStat Zuegelschub Statistik siehe wiki help
opt* Optionale Optionen
-f force: ignoriere QualitaetsVerletzungen
oder dbx c im QualitaetsMember
-aAuft oder Auft: AuftragsMember oder DSN
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: vPT VP*, keeptgt 0, qCheck 0, dbaCheck 0, ddlOnly 1
ca, bmc, ibm
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
wiki help http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Dbx
************************************************************************
19.11.2015 Walter remote edit, anaPre .......
*/ /* end of help
8. 6.2015 Walter kidi63 ==> klem43
8. 9.2014 Walter warning falls ungueltiger ZS und kein update tadm70
29. 8.2014 Walter RQ2 rein, RZ1 raus
14. 7.2014 Walter zstat in rq2
26. 5.2014 Walter dbx q: auch TS mit History Tabellen anzeigen
17. 3.2014 Walter zstat: zuegelschub Datum korrigiert
18. 2.2014 Walter Integration in auftragsTable
23.12.2013 Walter dbx q findet tables mit type<>T, wieder csm.div
4.12.2013 Walter zStat macht nur Warnung wenn ana <> auftrag
25.10.2013 Walter move rz8 --> rzx
2.10.2013 Walter rename Analysis in ZielRz nicht RZ4 wegen Release
27. 9.2013 Walter move to rz4
26. 9.2013 Walter promotePaths UT,ST,SIT,x,y,z, nachtrag *
23. 9.2013 Walter vp0/1/2/3/4/16/17 + vp0=default
16. 9.2013 Walter Nachtraege in zSTat geflickt
2. 9.2013 Walter ueberall class=log (auch PTA|)
30. 8.2013 Walter vP17 fuer CA Tool Version 17
19. 8.2013 Walter zstat in rz4
9. 8.2013 Walter schenv pro rz in JobCard generiert
19. 7.2013 Walter qualityCheck fuer VW, kein Check wenn keine Objs
8. 7.2013 Walter zStat auch im RR2
28. 6.2013 Walter fix qualityCheck fuer Db
26. 6.2013 Walter dbx c in QualitaetsMember fuer Weiterarbeit ohne -f
25. 6.2013 Walter v2.4: zSta, Namen angepasst auf ca ...
11. 6.2013 W. Keller qualityCheck mit Verglich in RZ2 und vq
14. 5.2013 W. Keller VPT für tool Alias PT
07. 5.2013 W. Keller crLib with primary 1000 cyls (avoid alloc err)
03. 4.2013 W. Keller IA erstellt jetzt exeJcl in dsn.dbx<dbSys>.exe
07. 3.2013 W. Keller in neuem Auftrag: CA und VDPS Warnung
06. 2.2013 W. Keller ca scope fuer Triggers
31. 1.2013 W. Keller integration anaPost und start, variable auf7
24. 1.2013 W. Keller initial edit macro AC fuer CA Analysen
18. 1.2013 W. Keller caDdl->ddl, caGlbChg->glbChg ohne dbxRen.*
9. 1.2013 W. Keller ddlOnly fuer CA eingebaut
8.01.2013 W. Keller rename fuer CA eingebaut: dbx ni030121 ren dbaf
13.12.2012 W. Keller Fehler bei 1 stellig import (verwechslung nachtr)
7.12.2012 W. Keller .stry -> .ana, vy -> va etc.
5.12.2012 W. Keller ca implementation I
9.11.2012 W. Keller ey und vy für view/edit strategy
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset hi
call jIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.aTb = 'oa1p.tAdm70A1'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if 1 & oArgs = '' then do
oArgs = 'count ~tmp.text(qx010011)'
say 'testing' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
m.e.toolAlias = 'P0'
do forever
r = substr(fun, 1 + 2*abbrev(fun, '-'))
if abbrev(fun, '-A') | length(fun) >= 8 then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then
m.auftrag.force = 1
else if abbrev(fun, '-') then
call err 'bad opt' fun 'in' wArgs
else
leave
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = iiDS(org)'.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
end
if 1 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ1 then
m.myDbSys = DBAF
else if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
call mapPut e, 'rexxLib', 'DSN.DB2.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
call mapPut e, 'tst', date('s') time()
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if fun == 'Z' then
return zglSchub(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if fun = 'COUNT' then
return countAna(args)
if wordPos(fun, 'AA NC NW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if wordPos(fun, 'AC AW') > 0 then
return nextAuftragFromATb(word(args, 1),
, substr(fun, 2), word(args, 2))
else if fun = 'C' & m.editMacro,
& right(m.edit.dataset, 8) = '.QUALITY' then
return qualityOk(fun, args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
else if fun = 'CPDUM' then
return cpDum(args)
else if fun = 'CRLIB' then
return crLib(args)
else if fun = 'REN' then
return renExeDsns(m.auftrag.member, args)
else if fun = 'ZSTAT' then
return zStat(args)
call memberOpt
if m.sysRz <> 'RZ4' then
call err 'dbx laeuft nur noch im RZ4'
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if abbrev(fun, 'E') | abbrev(fun, 'V') then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
ii = 'Marc ma'
else if m.uId = 'A390880' then
ii = 'Martin sm'
else if m.uId = 'A540769' then
ii = 'Walter wk'
else if m.uId = 'A754048' then
ii = 'Alessandro ac'
else if m.uId = 'A790472' then
ii = 'Agnes as'
else if m.uId = 'A828386' then
ii = 'Reni rs'
else if m.uId = 'A586114' then
ii = 'Stephan sz'
else
ii = m.uId '??'
parse var ii m.uNa m.uII
m.e.toolVers = ''
m.scopeTypes = 'DB TS TB VW AL IS IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths neu */
m.promN = 'X Y Z Q R P'
m.promN_A = 'UT ST SI SIT ET IT PQ PA PR'
m.promN_T = 'X Y Z,Q Z,Q X Y,Z,Q Q R P'
m.promD.1 = 'RZX/DE0G RZY/DE0G RZZ/DE0G' ,
'RQ2/DBOF RR2/DBOF RZ2/DBOF'
m.promD.2 = 'RZX/DEVG RZY/DEVG RZZ/DEVG' ,
'RQ2/DVBP RR2/DVBP RZ2/DVBP'
m.promD.0 = 2
/* promI columns in auftragsTable aTb */
m.promI.0 = 0
call dbxI2 'UT RZX/DE0G DEVG UT_RZX_DE0G ID1'
call dbxI2 'ST RZY/DE0G DEVG ST_RZY_DE0G ID4'
call dbxI2 'SIT RZ1/DBTF DVTB SIT_RZ1_DBTF ID2'
call dbxI2 'SIT RZZ/DE0G DEVG SIT_RZZ_DE0G ID3'
call dbxI2 'PQA RQ2/DBOF DVBP PTA_RZQ_DBOF ID6'
call dbxI2 'PTA RR2/DBOF DVBP PTA_RR2_DBOF ID5'
call dbxI2 'PROD RZ2/DBOF DVBP PROD_RZ2_DBOF ID7'
m.lastSaidToolV = 'P0'
return
endProcedure dbxIni
dbxI2: procedure expose m.
px = m.promI.0 + 1
m.promI.0 = px
parse arg m.promI.px
parse arg e rzD1 d2 fDt fUs
m.promI.rzD1 = fDt fUs
rzD2 = left(rzD1, 4)d2
m.promI.rzD2 = fDt fUs
return
endProcedure dbxI2
/*--- create the necessary dbx libraries locally ---------------------*/
crLib: procedure expose m.
parse arg subs
rz = sysvar(sysnode)
call crLibCr 'DSN.DBX.AUFTRAG'
call crLibCr 'DSN.DBX.DDL'
call crLibCr 'DSN.DBX.GLBCHG'
call crLibCr 'DSN.DBX.JCL'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call crLibCr 'DSN.DBX's1'.ANA'
call crLibCr 'DSN.DBX's1'.AN1'
call crLibCr 'DSN.DBX's1'.DDL'
call crLibCr 'DSN.DBX's1'.DD1'
call crLibCr 'DSN.DBX's1'.DD2'
call crLibCr 'DSN.DBX's1'.EXE'
call crLibCr 'DSN.DBX's1'.REC'
call crLibCr 'DSN.DBX's1'.RE1'
call crLibCr 'DSN.DBX's1'.RDL'
call crLibCr 'DSN.DBX's1'.AOPT'
call crLibCr 'DSN.DBX's1'.QUICK'
end
return 0
endProcedure crLib
crLibCr: procedure expose m.
parse arg lib
call dsnAlloc lib'(DUMMY) dd(l1)' ,
'::f mgmtClas(COM#A076) space(1000, 1000) cyl'
call tsoFree l1
return 0
endProcedure crLibCr
crLibRe: procedure expose m.
parse arg lib, old
if sysDsn("'"old"'") <> "OK" then
return crLibCr(lib)
call adrTso "rename '"old"' '"lib"'"
return 0
endProcedure crLibRe
/*--- create the necessary dbx libries in the specified rz -----------*/
cpDum: procedure expose m.
parse arg rz subs
call cpDum1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.AUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.CDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call cpDum1 rz, 'DSN.DBX.JCL(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.MASK(DUMMY)'
call cpDum1 rz, 'DSN.DBX.OVRCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
*/call cpDum1 rz, 'DSN.DBX.DDL(DUMMY)'
if rz = 'RZ1' then
call cpDum1 rz, 'DSN.DBX.RENAMDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.GLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call cpDum1 rz, 'DSN.DBX's1'.ANA(DUMMY)',
, 'DSN.DBXDBAF.ANA(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.REC(DUMMY)',
, 'DSN.DBXDBAF.REC(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.DDL(DUMMY)',
, 'DSN.DBXDBAF.DDL(DUMMY)'
end
return 0
endProcedure cpDum
cpDum1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???cpDum' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
endProcedure cpDum1
renExeDsns: procedure expose m.
parse arg ana, dbsy
if length(ana) <> 8 then
call errHelp 'bad analysis' ana 'for ren'
if length(dbsy) <> 4 then
call err 'bad dbSystem' dbSy 'for ren'
if ana = m.edit.member then do
call memberOpt
call analyseAuftrag
ana = overlay(m.e.nachtrag, ana, 8)
end
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
/*say 'y' ly 'l' last 'dsn' m.csi.cx */
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = m.ut.alfUC
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
return 0
endProcedure renExeDsns
/*--- die Konfiguration pro db2 dbSy -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, dbSy
call configureRZ rz
call configuredbSy rz, dbSy
return
endProcedure configureRZSub
configureDbSy: procedure expose m.
parse arg rz, dbSy
call mapPut e, 'subsys', dbSy
if rz = 'RZX' then
call mapPut e, 'location', 'CHROI00X'dbSy
else if rz = 'RZY' then
call mapPut e, 'location', 'CHROI00Y'dbSy
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'dbSy
else
call mapPut e, 'location', 'CHSKA000'dbSy
return
endProcedure configureDBSy
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.promD.1)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.promD.1, rx+4, 4)
call mapPut e, 'schenv', 'DB2ALL'
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rz = m.myRz then
call mapPut e, 'csmDD'
else
call mapPut e, 'csmDD', ",(SUBSYS=(CSM,'SYSTEM="rz"'))"
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PB')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', 'DB2@.'zz'.'px'.DSNLOAD'
if toolV \== '' then
m.e.toolVers = toolV
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* toolV = copies(m.e.toolVers, rz == 'RZ1') */
toolV = m.e.toolVers
toolRZAl = zz'.'if(toolV == '', 'P0', toolV)
if m.lastSaidToolV \== substr(toolRzAl, 5) then do
m.lastSaidToolV = substr(toolRzAl, 5)
say 'tool version unter Alias' toolRzAl,
if(substr(toolRzAl, 5) =='P0', '==> v16')
end
call mapPut e, 'capref', 'DSN.CADB2.'toolRzAl
call mapPut e, 'caload', 'DSN.CADB2.'toolRzAl'.CDBALOAD'
call mapPut e, 'cacr', DBX
if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'e}dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'e}Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt, ai
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ4' then
if m.myRz = 'RZ1' then
call err 'dbx wurde ins RZ4 gezuegelt'
else
call err 'Auftrag für RZ' rz 'muss aus RZ4 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if wordPos(make, 'C W') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn, ai
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if ai \== '' then do
call sqlUpdate 7, 'update' m.aTb "set workliste='"nn"'" ,
", chg='"make"'",
"where workliste='' and pid ='"m.ai.pid"'" ,
" and name ='"m.ai.name"'"
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
cChgs = 'ALLLALLL'
iChgs = 'QZ91S2T'
end
else do
ow = 'S100447'
end
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
if ai == '' then do
/* loops in 2015 and later ......
zglS = '20130208 20130510 20130809 20131108' ,
'20140214 20140509 20140808 20141114 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
*/ zglSchub = '---'
best = 'pid name tel'
end
else do
zglSchub = m.ai.einfuehrung m.ai.zuegelschub
best = strip(m.ai.pid) strip(m.ai.name)
end
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller ' best ,
, ' cChgs ' cChgs ,
, ' iChgs ' iChgs ,
, ' keepTgt 0 '
if abbrev(auftName, 'VV') | abbrev(auftName, 'VDPS') then
call mAdd auftrag ,
, ' * ---------- Achtung VDPS -------------------------|' ,
, ' * nach jeder Aenderung alle anderen aktuellen |' ,
, ' * VDPS Auftraege Comparen (= DDL akutalisieren) |'
call mAdd auftrag ,
, 'source RZX/DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%'
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- naechsten Auftrag aus Auftragstabelle --------------------------*/
nextAuftragFromATb: procedure expose m.
parse arg pre, make, srch
srch = '%'translate(strip(srch))'%'
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where workliste = '' and pid not like 'ADMI%' and (" ,
"translate(pid) like '"srch"'" ,
"or translate(name) like '"srch"')" , ai
if m.ai.0 = 1 then
ax = 1
else if m.ai.0 < 1 then
call err 'e}kein Auftrag like' srch 'gefunden'
else do forever
say m.ai.0 'auftraege like' srch
do ax=1 to m.ai.0
say ax m.ai.ax.pid m.ai.ax.name m.ai.ax.einfuehrung ,
m.ai.ax.zuegelschub
end
say 'welcher Auftrag? 1..'m.ai.0 'oder - fuer keinen'
parse pull ax .
if strip(ax) == '-' then
return ''
if verify(ax, '0123456789') = 0 & ax > 0 & ax <= m.ai.0 ,
& symbol('m.ai.ax.zuegelschub') == 'VAR' then
leave
say 'ungueltige Wahl:' ax
end
return nextAuftrag(pre, make, , 'AI.'ax)
endProcedure nextAuftragFromATb
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', m.e.auf7 || m.e.nachtrag
if m.e.qCheck == 0 then nop
else if m.sysRz \== 'RZ1' & m.sysRz \== 'RZ4' then
say 'no quality check from' m.sysRz
else do
qx = m.scopeSrc.rz'/'m.scopeSrc.dbSy
px = m.promPath
qy = word(m.promD.px, words(m.promD.px))
if qualityCheck(qx, qy) then do
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 0
call adrIsp 'vput' vAns 'shared'
ddlxP = substr(m.auftrag.member, 8, 1)
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
call adrIsp "view dataset('"qDsn"'),
macro(ddlX) parm(ddlxP)",4
call adrIsp 'vget' vAns 'shared'
if pos('F', opts) < 1 & \ m.auftrag.force ,
& value(vAns) \== 1 then
return
else
say 'Compare trotz Qualitaetsfehlern'
end
end
m.o.0 = 0
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.dbSy, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast m.e.auf7 || nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast m.e.auf7 || nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
call mapPut e, 'keepTgtV', copies('KEEPTGT,', m.e.keepTgt)
if m.e.tool == ca then
call caDDL o, scopeSrc, translate(mapExp(e, m.e.cChgs))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeSrc.rz'/'m.scopeSrc.dbSy ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat","DDL") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- in the qualityMember say dbx c
to continue processing without option -f ------------------*/
qualityOk: procedure expose m.
parse arg fun
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 1
call adrIsp 'vPut' vAns 'shared'
return 0
endProcedure qualityOk
/*--- find the naming convention for a rz and dbSystem --------------*/
namingConv: procedure expose m.
parse arg rz, dbSy, var
if rz = '.' then do
if pos('.', dbSy) > 0 then
call err 'namingConv old target' dbSy
if pos('/', dbSy) > 0 then
parse var dbSy rz '/' dbSy
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(dbSy)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', m.o.
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh . , a1 a2
call analyseAuftrag
if length(wh) > 2 then do
llq = wh
end
else do /* abbrev: first or first and last character */
ll = ' ANA AN1 AOPT DDL DDI DD1 DD2 EXE EXO' ,
'JCL QUALITY QUICK REC RE1 RDL START'
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then do
d = '* .JCL' m.e.auftrag
end
else if llq == 'QUALITY' | LLQ == 'DDL' then do
d = '* .'llq m.e.auf7 || left(a1 || m.e.nachtrag, 1)
end
else if llq == 'EXO' then do
end
else do
trace ?r
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
if llq == 'DDI' then
llR = 'DDL'
else
llR = llq
d = r2 d2'.'llR m.e.auf7 || n2
end
parse var d rz dsn mbr
eFun = word('Edit View', 1 + (fun \== 'E'))
if wh = 'Q' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wh == 'A' | wh == 'R' then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"m.libPre || dsn"("mbr")')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"m.libPre || dsn"')",
"member("mbr")" mac, 4
return
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call setIf jOut
call setIf jOut'.TWO'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = a2rzDbSysProm(rzDbSyList)
done = ''
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' dbSy
if opt == '*' then do
nachAll = m.compares
end
else if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if fun = 'IE' & (r == 'RZ2' ,
| (r == 'RZ4' & \ (abbrev(m.e.auftrag, 'Q') ,
|abbrev(m.e.auftrag, '@E') ,
|abbrev(m.e.auftrag, 'WK')))) then
call err 'ie fuer Prod nicht erlaubt:' r'/'dbSy
if m.e.tool = 'CA' then
nachAll = right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
if trgNm = '' then
call err 'compare not found for nachtrag' nachAll
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelN8, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs
else
call mapPut e, 'change',m.e.auftrag':'nachAll'/' ,
|| m.imp.seq'_'zs
call mapPut e, 'change', chaPre'.'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rzDbSys
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', m.e.auf7 || right(nachAll, 1)
done = done rzDbSys
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureDbSy r, dbSy
if m.e.tool == 'CA' then
call caImport jOut, fun, nachAll,
, translate(mapExp(e, m.e.iChgs)),
, translate(mapExp(e, m.e.iMap)),
, translate(mapExp(e, m.e.iRule))
else
call ibmImport jOut, fun, r, dbSy, nachAll,
, translate(mapExp(e, m.e.impMask)),
, translate(mapExp(e, m.e.impIgno))
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fu2)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
call addJobError jOut
call writeSub jOut
sq = ''
if m.e.zuegelN8 \== '' then do
today = translate('78.56.1234', date('s'),'12345678')
do dx=1 to words(done)
d1 = word(done, dx)
if symbol('m.promI.d1') \== 'VAR' then
call warn 'no col for' d1 'in AuftragsTable' m.aTb
else
sq = sq"," word(m.promI.d1, 1) "= '"today"'," ,
word(m.promI.d1, 2) "= '"m.uII"'"
end
end
if sq == '' then do
call warn 'zuegelSchub='m.e.zuegelSchub ,
'kein update in AuftragsTabelle' m.aTb
end
else do
call sqlConnect m.myDbSys
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'"
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'not in table' m.aTb
else if m.sql.1.updateCount \== 1 then do
call sqlUpdate 99, 'rollback'
call err 'auftrag' m.e.auftrag 'got' ,
m.sql.1.updateCount 'updateCount'
end
call sqlCommit
call sqlDisconnect
end
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
toRz = m.myRz
call mapPut e, 'toRz', toRz
if m.o.send.0 \== 0 & m.sysRz \== toRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.toRz.c1 \== 1 then do
m.cdlSent.toRz.c1 = 1
if sAft == '' then do
call mapPut e, 'cdl', dsnSetMbr(c1)
call addIf o
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIf o, 'end'
call setIf o, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
call addIf o
call mAddSt o, o'.TWO'
call addIf o, 'end'
m.o.ifLine = m.o.two.ifLine
end
else do
call addIf o
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call addJobError o'.TWO'
call mAddSt o, o'.TWO'
call mAdd o, la
call addIf o, 'end'
call setIf o, 'SUB'toRz
end
m.o.two.0 = 0
call setIf jOut'.TWO'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o'.SEND', c1
end
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TWO', nachAll
return
endProcedure ibmImport
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
call addIf o
ic = skelStem('Imp')
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIf o, 'end'
call setIf o, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddC.1 = 1
ddC.2 = 2
ddC.3 = 'L'
ddlIx = 3 - (iChgs \== '') - m.e.anapost
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib|| ddC.ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddC.ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddlBB
end
call addIf o'.TWO'
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly == '') ,
copies('keepTgt0', m.e.keepTgt == 0) ,
copies('anaPost0', m.e.anaPost == 0)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AOPT'
call mapPut e, 'stry', nact
call addIf o'.TWO'
call stepGroup
ddlImp = ddlLib'L('nact')'
if m.e.anaPost then do
call mapPut e, 'ddlIn', ddlAA
call mapPut e, 'ddlOut', ddlImp
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'PRE'
call addIf o'.TWO'
end
call mapPut e, 'ddlin', ddlImp
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AUTO'
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
call stepGroup
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
if m.e.aUtil = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' m.e.aUtil' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
call addIf o'.TWO'
call mapExpAll e, o'.TWO', skelStem('CAna')
if m.e.anapost then do
call mapExpAll e, o'.TWO', skelStem('CPost')
call setIf o'.TWO', 'ANA', 0 4, 'POST'
end
else do
call setIf o'.TWO', 'ANA', 0 4
end
call addIf o'.TWO', 'end'
call addIf o'.TWO'
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
oldIf = m.o.two.ifLine
call setIf o'.TWO'
call mapPut e, 'fun', 'execute'
call mapExpAll e, o'.TWO', skelStem(m.jobcard)
call mAdd o'.TWO', '//* Zuegelschub' m.e.zuegelschub k,
, '//* analyse ' date(s) time() m.uNa ,
, '//* nachtrag ' m.e.nachtrag m.e.auf7 || m.e.nachtrag,
, '//* rename old unloads: TSO DBX' m.e.auf7||m.e.nachtrag,
"REN" mapGet(e, 'subsys')
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call mAdd o'.TWO', '}!'
call addIf o'.TWO', 'end'
m.o.two.ifLine = oldIf
call stepGroup old
call setIf o'.TWO', 'EXCP', 0 4
end
if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'EXE', 0 4
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIf o, 'end'
call setIf o, 'DDL', 0 4
call addIf o
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
call addIf o
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
if m.o.ifLine == ''then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o,'// ENDIF' /* for if in skel dbxCRen */
call setIf o, 'RANA', 0 4
return
endProcedure caImpRename
stepGroup: procedure expose m.
parse arg f
old = m.e.stepNo
if f \== '' then
no = f
else
no = old + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return old
endProcedure stepGroup
setIf: procedure expose m.
parse arg o, stp, codes
if stp == '' | m.e.tool = 'IBM' then
li = ''
else do
li = ''
do ax=2 by 2 to arg()
stp = arg(ax)
codes = arg(ax+1)
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = li 'AND' stp'.RUN AND'
if codes == '' then
li = li stp'.RC=0'
else if words(codes) = 1 then
li = li stp'.RC='strip(codes)
else do
li = li '('stp'.RC='word(codes, 1)
do cx=2 to words(codes)
li = li 'OR' stp'.RC='word(codes,cx)
end
li = li')'
end
end
li = substr(li, 6)
end
m.o.ifLine = li
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt, cond
if m.o.ifLine == '' & opt \== 1 then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else do
pr = '// IF'
if cond == '' then
cond = m.o.ifLine
cond = space(cond, 1)
do while length(cond) > 53
ex = lastPos(' ', left(cond, 53))
call mAdd o, pr left(cond, ex-1)
cond = substr(cond, ex+1)
pr = left('//', length(pr))
end
call mAdd o, pr cond 'THEN'
end
return
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if cond = '' then
cond = 'RC=0'
call addIf o, 1, 'ABEND OR RC > 4 OR NOT (' cond ')'
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.anaPost = 1
m.e.ddlOnly = 0
m.e.zuegelschub = ''
m.e.aOpt = ''
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER ICHGS IMPMASK IMAP IRULE IMPIGNO'
varWu = 'CCHGS COMMASK COMIGNO' ,
'AOPT AMODEL AUTIL VP0 VP1 VP2 VP3 VP4 VPT VP16 VP17' ,
'KEEPTGT DBACHECK QCHECK CA BMC IBM DDLONLY ANAPOST'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.auf7 = left(w2, 7)
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.e.anaPost = m.e.anaPost == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
if m.e.ddlOnly == '' | m.e.ddlOnly == 1 then
m.e.ddlOnly = ''
else
m.e.ddlOnly = 'UNLOAD'
if m.e.cChgs == '' then
m.e.cChgs = 'PROT'm.e.prodDbSys
if m.e.iChgs == '' then
m.e.iChgs = dsnGetMbr(m.e.impMask)
else if m.e.impMask == '' then
m.e.impMask = m.libPre'.MASK('m.e.iChgs')'
if m.e.iRule == '' then
m.e.iRule = dsnGetMbr(m.e.impIgno)
else if m.e.impIgno == '' then
m.e.impIgno = m.libPre'.MASK('m.e.iRule')'
call mapPut e, 'aModel', m.e.aModel
zt = translate(m.e.zuegelschub, '000000000', '123456789')
if zt == '00.00.0000' then do
m.e.zuegelN8 = translate('67893401', m.e.zuegelSchub,
,'0123456789')
end
else if zt == '00000000' then do
m.e.zuegelN8 = m.e.zuegelSchub
m.e.zuegelschub = translate('78.56.1234', m.e.zuegelN8,
,'12345678')
end
else do
m.e.zuegelN8 = ''
end
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.dbSy, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop dbSy
say ' scope ' m.scp.0 m.scp.dbSy ,
' target ' m.scopeTrg.0 m.scopeTrg.dbSy
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
sayImp: procedure expose m.
do ix=1 to m.imp.0
say 'imp' m.imp.ix.nachtrag 'to' m.imp.ix.rz'/'m.imp.ix.dbSys
end
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureDbSy m.scopeTrg.rz, m.scopeTrg.dbSy
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- create jcl to copy one member to rz toRz and library toLib -----*/
copyMbr: procedure expose m.
parse arg o, mbr, frLib, toRz, toLib
call mapPut e, 'mbr', mbr
call mapPut e, 'frLib', dsnSetMbr(frLib)
call mapPut e, 'toRz', toRz
call mapPut e, 'toLib', dsnSetMbr(toLib)
call addIf o
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIf o, 'end'
call setIf o, 'COPY', 0
return
endProcedure copyMbr
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlConnect m.scp.dbSy
else
call sqlConnect m.scp.rz'/'m.scp.dbSy
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
trace ?r
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
removeQualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure removeQualityCheck
/*--- Qualitaets Pruefung mittels ddlCheck ---------------------------*/
qualityCheck: procedure expose m.
parse arg x, y
m.spezialFall.done = ''
lst = ''
scp = 'SCOPESRC'
o = 'AUFTRAG'
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then
f1 = 'db:'m.sn.name
else if m.sn.Type = 'TS' then
f1 = 'ts:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'TB' then
f1 = 't:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'VW' then
f1 = 'v:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'IX' then
f1 = 'i:'m.sn.qual'.'m.sn.name
else
iterate
f1 = space(f1, 0)
if wordPos(f1, lst) > 0 then
iterate
lst = lst f1
end
m.o.orig = 'rmQu' m.o.orig
if lst = '' then do
say 'qualitycheck no objects to check'
call mAdd o, '|| qualitycheck no objects to check'
return 0
end
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
cRes = ddlCheck('CHECK' qDsn x y lst)
call splitNl cr, cRes
cr1 = substr(m.cr.1, 4)','
if pos('\n', cRes) > 0 then
cr1 = left(cRes, pos('\n', cRes)-1)','
else
cr1 = cRes','
res = pos('q,', cr1) > 0 | pos('*sb,', cr1) > 0 ,
| pos('*p', cr1) > 0 | pos('*n,', cr1) > 0 ,
| pos('special', cr1) > 0 | pos('*-,', cr1) > 0
if \ res then do /* add new | lines to auftrag */
call mAdd o, '|| qualitycheck ok:' substr(m.cr.1, 4)
end
else do
call mAdd o, '|| qualitycheck:' substr(m.cr.1, 4)
call mAddSt o, cr, 2
end
return res
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
removeSspezialFall: procedure expose m. --> ddlCheck
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-' left(m.st.sx, 78)
end
return
endProcedure removeSpezialFall
/*--- mask handling initialise ---------------------------------------*/
removemaskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
removemaskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
removetestMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
removeMaskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
removemask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
removemaskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
removemaskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
removemaskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg dbSy
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & dbSy == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if dbSy = '' then
dbSy = if(subs2 == '', m.pr1Sub, subs2)
dbSy = translate(dbSy, '/', '.')
if abbrev(dbSy, m.sysRz'/') then
dbSy = substr(dbSy, 5)
call sqlConnect dbSy
dbSy = translate(dbSy, m.ut.alfLC, m.ut.alfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu dbSy) < 70 then
neu = left(neu, 68 - length(dbSy)) '*'dbSy
else if length(neu dbSy) < 80 then
neu = neu '*'dbSy
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(name)," ,
"case when nTables <> 1",
"then 'ty=' || type" ,
"|| ', ' || nTables || ' tables||| '",
"else value( (select 'tb '" ,
"|| strip(t.creator) ||'.'|| strip(t.name)",
"|| case when t.type = 'T' then ''" ,
"else ' ty=' || t.type end" ,
"from sysibm.systables t" ,
"where t.type not in ('A','V')" ,
"and t.dbName=s.dbName and t.tsName=s.name" ,
"), 'not found')" ,
"end" ,
"from sysibm.systableSpace s" ,
"where dbName" sqlClause(qu) "and name" sqlClause(nm)
/*???else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end" ,
"|| min(strip(creator) ||'.'|| strip(name))",
"|| case when count(*) = 1 and min(type) <> 'T'" ,
"then ' ty=' || min(type) else '' end" ,
"from sysibm.systables" ,
"where type not in ('A','V')" ,
"and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName" ???????????*/
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case type when 'V' then 'vw'",
"when 'A' then 'al' else 'tb' end," ,
"strip(creator) || '.' || strip(name)" ,
"|| case when type <> '"left(ty, 1)"'" ,
"then ' ty=' || type else '' end," ,
"case when type = 'A' then 'for '" ,
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type" if(ty=='TB', "not in ('A', 'V')" ,
, "= '"left(ty, 1)"'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IS' then
sql = "select 'is', strip(dbName) ||'.'|| strip(indexSpace),",
"'tb ' || strip(tbCreator)|| '.' || strip(tbName)" ,
" || ' ix ' || strip(name)" ,
'from sysibm.sysIndexes' ,
'where dbname' sqlClause(qu),
'and indexSpace' sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = m.e.auf7 || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' oDsn)
call caDD1 o, scp, GlbChg, oDsn
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg, ddlOut
call mapPut e, 'user', userid()
call mapPut e, 'ddlOut', ddlOut
call mapExpAll e, o, skelStem('CCOM')
call mapPut e, 'comm', mapExp(e, 'dbx $fun',
copies('recover', pos('.RDL(', ddlOut) > 0)'DDL' ,
'$AUFTRAG $NACHTRAG')
if abbrev(scp, '//') then
call mAdd o, scp, '// DD *'
else do sx=1 to m.scp.0
call rcmQuickAdd o, m.scp.sx.type, m.scp.sx.qual, m.scp.sx.name
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".GlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.dbSy \== m.scopeTrg.dbSy then
call err 'bmc compare on different dbSystems not implemented'
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlConnect m.scp.dbSy
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
zglSchub: procedure expose m.
parse arg fun rest
if length(fun) = 4 & datatype(fun, 'n') then
parse arg zgl fun rest
else
zgl = substr(date('s'), 3, 4)
only18 = fun == 18
if only18 then
parse var rest fun rest
if fun = '' then
call err 'zglSchub kein Fun fuer Auftraege:' arg(1)
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
copies("and einfuehrungs_zeit = '18:00'", only18) , zsa
call sqlDisconnect
do zx=1 to m.zsa.0
if m.zsa.zx.workliste = '' then
iterate
say zx m.zsa.zx.workliste m.zsa.zx.auftrag ,
m.zsa.zx.einfuehrungs_zeit m.zsa.zx.id7
call work m.zsa.zx.workliste fun rest
end
endProcedure zglSchub
/*--- zStat Zuegelschub Statistik ------------------------------------*/
zstat a? yymm? - in rz4, create AyyMM mit AuftragsListe
----------------------------------------------------------------------*/
zStat: procedure expose m.
parse upper arg aArg
parse upper arg fun zgl
rz = sysvar('sysNode')
if fun = '' then
if rz = 'RZ4' then
fun = 'A'
else if rz = 'RZ2' | rz = 'RR2' | rz = 'RQ2' then
fun = 'S'
z0 = translate(zgl, '000000000', '123456789')
if zgl = '' then
z1 = substr(date('s'), 3, 4)
else if z0 == '0000' then
z1 = zgl
else if z0 == '000000' then
z1 = substr(zgl, 3)
else if z0 == '00.00.00' then
z1 = translate('5634', zgl, '12.34.56')
else
call err 'bad Zugelschub should be yymm or dd.nn.yy not' zgl
aDsn = m.libPre'.ZGL(ZSTA'z1')'
sDsn = m.libpre'.ZGL(ZSTS'z1')'
if fun = 'A' then do
if rz <> 'RZ4' then
call err 'zstat a... only in rz4'
if sysDsn("'"aDsn"'") == 'OK' then
call err "e}"aDsn "existiert schon"
call zStatAuftragsListe z1, m.libPre'.auftrag', aDsn
end
else if fun == 'S' then do
if rz <> 'RZ2' & rz <> 'RR2' & rz <> 'RQ2' & rz <> 'RZ4' then
call err 'zstat s... only in rz2 or rz4'
if sysDsn("'"aDsn"'") \== 'OK' then
call err aDsn "existiert nicht"
call zStatsStatistik z1, aDsn, sDsn
end
else
call err 'i}bad fun' fun 'in arguments zStat' aArg
return 0
endProcedure zStat
zStatAuftragsListe: procedure expose m.
parse arg zgl, lib, outDsn
zg2 = '20'zgl
zg3 = translate('.34.12', zgl, '1234')
zg4 = translate('.cd.20ab', zgl, 'abcd')
call sqlConnect m.myDbSys
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy rTy ., t aa
m.rcm_quickT2DB2.t = dTy
if rTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = rTy
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
mv = 'UNITCNT(30)' /* 3.10.13 wieder zurueck */
say 'creating' dsn 'with multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call tsoFree word(alRes, 2)
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'",
c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if disp = 'NEW' & nn \== '' then
a2 = a2 dsnCreateAtts( , nn, 1)
if retRc <> '' | nn = '' then
return adrCsm('allocate' al a2 rest, retRc)
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return 0
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX'
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 77
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/* copy csm end *******************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort.comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort.comparator = "aLe =" le "; aRi =" ri";" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
call jIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlOIni
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
hst = ''
cTy = 'Rx'
end
if m.sql.conType==cTy & m.sqlHost==hst & m.sqlconDbSYs == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
else
m.sql.conDbSys = sys
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conDbSys = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, resTy
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if (sub == '' & m.sql.conDbSys== '') ,
| (sub \== '' & m.sql.conDbSys \== sub) then
call sqlConnect sub
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call scanSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql.sqlHaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then
return sqlMsgLine( , upds, src, coms 'commits')
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ut2Lc(fun)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut.alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%qn %S'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlReset crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec 'describe cursor c'crs 'into :m.sql.'crs'.D'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%qn v, f %s')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = oNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conDbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, resTy, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
f = ''
if resTy \== '' then do
f = oClaMet(class4Name(resTy), 'oFlds')
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk, resTy
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
if resTy \== '' then
m.sql.cx.type = class4Name(resTy)
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- return csv header line -----------------------------------------*/
sqlHeaderCSV: procedure expose m.
parse arg cx
x = sqlRxFetchVars(cx)
return mCatFT('SQL.'cx'.COL', 1, m.sql.cx.d.sqlD, '%qn,%s')
endProcedure sqlHeaderCSV
/*--- fetch next row return it as csv line, return '' at end ---------*/
sqlFetchCSV: procedure expose m.
parse arg cx, retOk
dst = 'sql.csvFetch'
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return ''
if fetCode < 0 then
return fetCode
res = ''
do kx=1 to m.sql.cx.d.sqlD
cn = m.sql.cx.col.kx
val = m.dst.cn
if m.sql.cx.d.kx.sqlType // 2 = 1 & m.dst.col.sqlInd < 0 then
res = res','m.sqlNull
else if pos(',', val) > 0 | pos('"', val) > 0 then
res = res','quote(val, '"')
else
res = res','val
end
return substr(res, 2)
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlRxClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlRxClose cx
return res
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = oClaMet(f, 'oFlds')
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlRxFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000, sqlErrd.5)
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut.alfRexN1) > 0 then
iterate
ex = verify(src, m.ut.alfRex, 'n', cx)
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
else
fmt = '%s%qn %s%qe%q^'fmt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%Qn', m.line)
end
call jClose m
return res || f(fmt'%Qe')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
sta = 'tt'
res = ''
do forever
do while scanSBEnd(m)
if \ jCatSqlNl(m) then
return strip(res)
end
bx = m.m.pos
sta = scanSql2Stop(m, sta, stop)
s1 = left(sta, 1)
if pos(s1, stop) > 0 then do
if res <> '' then
return strip(res)
end
else if s1 == '-' | s1 == '/' then
res = res' '
else if pos('/', sta) = 0 then
res = res || substr(m.m.src, bx, m.m.pos - bx)
end
/*-------- ?????????????????????
jCatSqlNext?: procedure expose m.
parse arg m, stop
res = ''
bx = m.m.pos
do forever
call scanUntil m, '"''-/'stop
if scanSBEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if scanLit(m, "'", '"') then do
c1 = m.m.tok
do while \ scanStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call scanChar m, 1
if res <> '' then
return strip(res)
bx = m.m.pos
end
else if \ scanLit(m, '-', '/') then do
call err 'bad char at' substr(m.m.src, m.m.pos) 'in' m.m.src
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return strip(res)
end
endProcedure jCatSqlNext
??????????????*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new return jReset("m.class.basicNew", arg, arg2, arg3)",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new return jReset("m.class.basicNew", arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if oClaInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: 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
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: 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
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
if the parent is class OLazyMet, a methof found there is
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o.ini == 1 then
return
m.o.ini = 1
call mIni
m.o.escW = '!'
m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
call oAddCla m.o.lazyGen
return
endProcedure oIni
/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla
/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
call err 'bad class name' cl 'in oAddCla('cl',' parents')'
if oIsCla(cl) then
call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
do px=1 to words(parents)
if \ oIsCla(word(parents, px)) then
call err word(parents, px) 'is no class' ,
'in oAddCla('cl',' parents')'
end
m.o.cParent.cl = parents
return
endProcedure oAddCla
/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
if \ oIsCla(cl) then
call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
if symbol('m.o.cMet.cl.met') == 'VAR' then
call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
m.o.cMet.cl.met = cont
return
endProcedure oAddMet
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
interpret oClaMet(cl, 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o.escW) then
return m.class.classW
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return oClaInheritsOf(cl, sup)
endProcedure oKindOf
oClaInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
if symbol('m.o.cParent.sup') \== 'VAR' then
sup = class4name(sup)
if cl == sup then
return 1
do sx=1 to words(m.o.cParent.cl)
if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
return 1
end
return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o.escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.o.cMet.ggClass.me') == 'VAR' then
return m.o.cMet.ggClass.me
code = oClaMet(ggClass, me, '---')
if code \== '---' then
return code
else if arg() >= 3 then
return arg(3)
return err('no method' me 'in class' className(ggClass) ,
'of object' m)
endProcedure objMet
oClaMet: procedure expose m.
parse arg cl, me
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
if \ oIsCla(cl) then do
c2 = class4Name(cl, '')
if c2 \== '' & oIsCla(c2) then do
cl = c2
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
end
else do
if arg() >= 3 then
return arg(3)
else
return err('no class' cl 'in oClaMet('cl',' me')')
end
end
code = oLazyMetGen(m.o.lazyGen, cl, me)
do px = 1 to words(m.o.cParent.cl) while code == '---'
code = oClaMet(word(m.o.cParent.cl, px), me, '---')
end
if code == '---' then do
if arg() >= 3 then
return arg(3)
else
return err('no met' me 'in class' cl)
end
m.o.cMet.cl.me = code
return code
endProcedure oClaMet
oLazyMetGen: procedure expose m.
parse arg lg, cl, me
if symbol('m.o.cMet.lg.me') \== 'VAR' then
return '---'
interpret m.o.cMet.lg.me
endProcedure oLazyMetGen
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.o.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProcedure oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
oClaClear: procedure expose m.
parse arg cla, m
interpret "drop cla;" oClaMet(cla, 'oClear')
return m
endProcedure oClaClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
call oClaMet cl, 'oFlds'
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = oNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" oClaMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.class.in2 = 0
call oIni
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
m.class.basicNew = "oMutate(mNew(cl), cl)"
call oAddMet m.o.lazyGen, 'new', "return classGenNew(cl, me)"
call oAddMet m.o.lazyGen,'oClear',"return classGenClear(cl, me)"
call oAddMet m.o.lazyGen,'oFlds',"return classGenFlds(cl, me)"
call oAddMet m.o.lazyGen, 'oCopy', "return classGenCopy(cl, me)"
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classFinish cr
call oClaMet cr, 'oFlds' /* generate flds */
end
m.class.in2 = 1
call oAddMet m.class.classV, 'oCopy', "return oCopyV(m, t)"
call classAddMet m.class.classV, 'o2String return m.m'
call classAddMet m.class.classW, 'o2String return substr(m, 2)'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if isNew & m.class.in2 then
call classFinish n
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
return n
endProcedure classNew
/*--- to the finish for new class cl -------------------------------*/
classFinish: procedure expose m.
parse arg cl, force
call oMutate cl, m.class.class
/* find super and sub classes */
m.cl.sub = ''
sups = ''
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 \== 'u' then
iterate
if wordPos(u1, sups) > 0 then
call err u1 'already in sups' sups': classSuperSub('cl')'
sups = sups u1
if wordPos(m.cl.SUB, cl) > 0 | symbol('m.u1.sub') \== 'VAR' then
call err cl 'is already in' u1'.sub' u1.SUB ,
|| ': classSuperSub('cl')'
m.u1.sub = strip(m.u1.sub cl)
end
m.cl.super = sups
/* add class to o */
call oAddCla cl, sups
if pos(m.cl, 'mfrsv') < 1 then do
allMets = ''
forceMets = ''
do cx=1 to m.cl.0
ch = m.cl.cx
if m.ch == 'm' then do
call oAddMet cl, m.ch.name, m.ch.met
allMets = allMets m.ch.name
end
else if symbol('m.class.forceDown.ch') == 'VAR' then
forceMets = forceMets m.class.forceDown.ch
end
myForce = ''
do fx=1 to words(forceMets)
parse value word(forceMets, fx) with fCla '#' fMet
if wordPos(fMet, allMets) < 1 then do
call oAddMet cl, fMet, m.o.cMet.fCla.fMet
myForce = myForce cl'#'fMet
allMets = allMets fMet
end
end
if myForce \== '' then
m.class.forceDown.cl = strip(myForce)
end
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object addresses */
call mNewArea cl, 'O.'substr(cl,7)
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
return
endProcedure classFinish
classAddMet: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
call mAdd cl, classNew('m' met code)
call oAddMet cl, met, code
return cl
endProcedure classAddMet
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
classGenNew: procedure expose m.
parse arg cl, met
return "m=" m.class.basicNew";" oClaMet(cl, 'oClear') ";" ,
"return m"
endProcedure classGenNew
classGenFlds: procedure expose m.
parse arg cl, met
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classGenFldsAdd cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
return cl'.FLDS'
endProcedure classGenFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classGenFldsAdd: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classGenFldsAdd(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classGenFldsAdd(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classGenFldsAdd f, m.cl.tx, nm
end
return 0
endProcedure classGenFldsAdd
classGenClear: procedure expose m.
parse arg cl, met
r = ''
call oClaMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
r = r classGenStmt(f1, "m.m~ = '"m.o.escW"';")
else
r = r classGenStmt(f1, "m.m~ = '';")
end
do sx=1 to m.cl.stms.0
r = r classGenStmt(m.cl.stms.sx, "m.m~.0 = 0;")
end
return r
endProcedure classGenClear
classGenStmt: procedure expose m.
parse arg f, st, resWo
isNice = translate(f) == f
resWo = translate(resWo) 'GGFF M'
fDod = '.'f'.'
do wx=1 to words(resWo) while isNice
isNice = pos('.'word(resWo, wx)'.', fDot) < 1
end
if isNice then
return repAll(st, '~', f)
else
return "ggFF = '"substr(f, 2)"';" repAll(st, '~', '.ggFF')
endProceduer classGenAss
classGenCopy: procedure expose m.
parse arg cl, me
r = repAll("if t == '' then t =" m.class.basicNew ";" ,
"else call oMutate t, cl;", 'cl', "'"cl"'")
ff = oClaMet(cl, 'oFlds') /* build code for copy */
do fx=1 to m.cl.flds.0
r = r classGenStmt(m.cl.flds.fx, 'm.t~ = m.m~;', 't')
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == '' then
st = ''
else do
r = r "st = '"substr(nm, 2)"';"
st = '.st'
end
r = r "m.t"st".0 = m.m"st".0;" ,
"do sx=1 to m.m"st".0;" ,
"call oClaCopy '"sc"', m"st".sx, t"st".sx; end;"
end
return r 'return t;'
endProcedure classGenCopy
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class.classV)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut.alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '%s%qn%s%qe%q^'fmt
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCatFT
mIni: procedure expose m.
if m.m.ini == 1 then
return
m.m.ini = 1
call utIni
m.mBase64 = m.ut.alfUC || m.ut.alfLc || m.ut.digits'+-'
m.m.area.0 = 0
call mNewArea
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 tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' readNxLiNo(m)li
endProcedure readnxPos
readNxLiNo: procedure expose m.
parse arg m
return m.m.buf0x + m.m.cx
endProcedure readnxLiNo
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'o' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'a' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(10, 1000) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
m.ut.alfId = m.ut.alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut.alfIdN1 = m.ut.digits /* not as first character */
m.ut.alfRex = m.ut.Alfa'.0123456789@#$?' /* charset puff mit ¬*/
m.ut.alfRexN1= '.0123456789'
m.ut.alfPrint = m.ut.alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.alfIdN1) > 0 then
return 1
else
return verify(src, m.ut.alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBXBB) cre=2016-01-19 mod=2016-01-19-11.33.17 A540769 ----
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.1
13.01.16
edit macro fuer CS Nutzung von CA RCM
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr us naechsten Auftrag ab Tabelle erstellen
aa: anzueigen, aw, ac entsprechendes Member editieren
n,na,nc,nt neuen Auftrag erstellen (nt = test)
q dbSy? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren, sonst Alle
* funktioniert nicht nur in Auftrag
* dbSy hier wird gesucht sonst in source
c op1? create ddl from source
i | ia | ie subs nct changes in Db2Systeme importier(+ana+exe)
subs = sub(,sub)*: Liste von Stufen/rzDbSys
sub: RR2/DBOF (im PTA), RZY(betr. dbSy)
X, Y, Z, Q, R, P, UT, ST, SIT, IT Abkuerzungen
==> sucht im PromotionPath
nct: Nachtrag: leer=noch nicht importiert sonst angegeb
8: Nachtrag 8, *: neuster, =: wie letztes Mal
v* ¦ e* rzDb? nt?: view/edit ana,cdl,ddl,exe etc. locally or remote
* ist der llq oder Abkuerzung: a->ana, a1->an1
rzDb gibt rz und dbsys: rzz/de0g, ze, z, etc
nt Nachtrag, sucht neuest Import mit diesen Bedingunen
ren dbSy rename DSNs der Execution der Analyse in DBSystem
z 18? fun args fuer alle Auftraege / 18:00 Auftraege des ZglSchubs
zStat Zuegelschub Statistik siehe wiki help
opt* Optionale Optionen
-f force: ignoriere QualitaetsVerletzungen
oder dbx c im QualitaetsMember
-aAuft oder Auft: AuftragsMember oder DSN
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: vPT VP*, keeptgt 0, qCheck 0, dbaCheck 0, ddlOnly 1
ca, bmc, ibm
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
wiki help http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Dbx
************************************************************************
19.11.2015 Walter remote edit, anaPre .......
*/ /* end of help
8. 6.2015 Walter kidi63 ==> klem43
8. 9.2014 Walter warning falls ungueltiger ZS und kein update tadm70
29. 8.2014 Walter RQ2 rein, RZ1 raus
14. 7.2014 Walter zstat in rq2
26. 5.2014 Walter dbx q: auch TS mit History Tabellen anzeigen
17. 3.2014 Walter zstat: zuegelschub Datum korrigiert
18. 2.2014 Walter Integration in auftragsTable
23.12.2013 Walter dbx q findet tables mit type<>T, wieder csm.div
4.12.2013 Walter zStat macht nur Warnung wenn ana <> auftrag
25.10.2013 Walter move rz8 --> rzx
2.10.2013 Walter rename Analysis in ZielRz nicht RZ4 wegen Release
27. 9.2013 Walter move to rz4
26. 9.2013 Walter promotePaths UT,ST,SIT,x,y,z, nachtrag *
23. 9.2013 Walter vp0/1/2/3/4/16/17 + vp0=default
16. 9.2013 Walter Nachtraege in zSTat geflickt
2. 9.2013 Walter ueberall class=log (auch PTA|)
30. 8.2013 Walter vP17 fuer CA Tool Version 17
19. 8.2013 Walter zstat in rz4
9. 8.2013 Walter schenv pro rz in JobCard generiert
19. 7.2013 Walter qualityCheck fuer VW, kein Check wenn keine Objs
8. 7.2013 Walter zStat auch im RR2
28. 6.2013 Walter fix qualityCheck fuer Db
26. 6.2013 Walter dbx c in QualitaetsMember fuer Weiterarbeit ohne -f
25. 6.2013 Walter v2.4: zSta, Namen angepasst auf ca ...
11. 6.2013 W. Keller qualityCheck mit Verglich in RZ2 und vq
14. 5.2013 W. Keller VPT für tool Alias PT
07. 5.2013 W. Keller crLib with primary 1000 cyls (avoid alloc err)
03. 4.2013 W. Keller IA erstellt jetzt exeJcl in dsn.dbx<dbSys>.exe
07. 3.2013 W. Keller in neuem Auftrag: CA und VDPS Warnung
06. 2.2013 W. Keller ca scope fuer Triggers
31. 1.2013 W. Keller integration anaPost und start, variable auf7
24. 1.2013 W. Keller initial edit macro AC fuer CA Analysen
18. 1.2013 W. Keller caDdl->ddl, caGlbChg->glbChg ohne dbxRen.*
9. 1.2013 W. Keller ddlOnly fuer CA eingebaut
8.01.2013 W. Keller rename fuer CA eingebaut: dbx ni030121 ren dbaf
13.12.2012 W. Keller Fehler bei 1 stellig import (verwechslung nachtr)
7.12.2012 W. Keller .stry -> .ana, vy -> va etc.
5.12.2012 W. Keller ca implementation I
9.11.2012 W. Keller ey und vy für view/edit strategy
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset hi
/* call jIni ?????? */
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.aTb = 'oa1p.tAdm70A1'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if 1 & oArgs = '' then do
oArgs = 'count ~tmp.text(qx010011)'
say 'testing' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
m.e.toolAlias = 'P0'
do forever
r = substr(fun, 1 + 2*abbrev(fun, '-'))
if abbrev(fun, '-A') | length(fun) >= 8 then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then
m.auftrag.force = 1
else if abbrev(fun, '-') then
call err 'bad opt' fun 'in' wArgs
else
leave
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = iiDS(org)'.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
end
if 1 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ1 then
m.myDbSys = DBAF
else if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
call mapPut e, 'rexxLib', 'DSN.DB2.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
call mapPut e, 'tst', date('s') time()
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if fun == 'Z' then
return zglSchub(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if fun = 'COUNT' then
return countAna(args)
if wordPos(fun, 'AA NC NW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if wordPos(fun, 'AC AW') > 0 then
return nextAuftragFromATb(word(args, 1),
, substr(fun, 2), word(args, 2))
else if fun = 'C' & m.editMacro,
& right(m.edit.dataset, 8) = '.QUALITY' then
return qualityOk(fun, args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
else if fun = 'CPDUM' then
return cpDum(args)
else if fun = 'CRLIB' then
return crLib(args)
else if fun = 'REN' then
return renExeDsns(m.auftrag.member, args)
else if fun = 'ZSTAT' then
return zStat(args)
call memberOpt
if m.sysRz <> 'RZ4' then
call err 'dbx laeuft nur noch im RZ4'
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if abbrev(fun, 'E') | abbrev(fun, 'V') then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
ii = 'Marc ma'
else if m.uId = 'A390880' then
ii = 'Martin sm'
else if m.uId = 'A540769' then
ii = 'Walter wk'
else if m.uId = 'A754048' then
ii = 'Alessandro ac'
else if m.uId = 'A790472' then
ii = 'Agnes as'
else if m.uId = 'A828386' then
ii = 'Reni rs'
else if m.uId = 'A586114' then
ii = 'Stephan sz'
else
ii = m.uId '??'
parse var ii m.uNa m.uII
m.e.toolVers = ''
m.scopeTypes = 'DB TS TB VW AL IS IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths neu */
m.promN = 'X Y Z Q R P'
m.promN_A = 'UT ST SI SIT ET IT PQ PA PR'
m.promN_T = 'X Y Z,Q Z,Q X Y,Z,Q Q R P'
m.promD.1 = 'RZX/DE0G RZY/DE0G RZZ/DE0G' ,
'RQ2/DBOF RR2/DBOF RZ2/DBOF'
m.promD.2 = 'RZX/DEVG RZY/DEVG RZZ/DEVG' ,
'RQ2/DVBP RR2/DVBP RZ2/DVBP'
m.promD.0 = 2
/* promI columns in auftragsTable aTb */
m.promI.0 = 0
call dbxI2 'UT RZX/DE0G DEVG UT_RZX_DE0G ID1'
call dbxI2 'ST RZY/DE0G DEVG ST_RZY_DE0G ID4'
call dbxI2 'SIT RZ1/DBTF DVTB SIT_RZ1_DBTF ID2'
call dbxI2 'SIT RZZ/DE0G DEVG SIT_RZZ_DE0G ID3'
call dbxI2 'PQA RQ2/DBOF DVBP PTA_RZQ_DBOF ID6'
call dbxI2 'PTA RR2/DBOF DVBP PTA_RR2_DBOF ID5'
call dbxI2 'PROD RZ2/DBOF DVBP PROD_RZ2_DBOF ID7'
m.lastSaidToolV = 'P0'
return
endProcedure dbxIni
dbxI2: procedure expose m.
px = m.promI.0 + 1
m.promI.0 = px
parse arg m.promI.px
parse arg e rzD1 d2 fDt fUs
m.promI.rzD1 = fDt fUs
rzD2 = left(rzD1, 4)d2
m.promI.rzD2 = fDt fUs
return
endProcedure dbxI2
/*--- create the necessary dbx libraries locally ---------------------*/
crLib: procedure expose m.
parse arg subs
rz = sysvar(sysnode)
call crLibCr 'DSN.DBX.AUFTRAG'
call crLibCr 'DSN.DBX.DDL'
call crLibCr 'DSN.DBX.GLBCHG'
call crLibCr 'DSN.DBX.JCL'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call crLibCr 'DSN.DBX's1'.ANA'
call crLibCr 'DSN.DBX's1'.AN1'
call crLibCr 'DSN.DBX's1'.DDL'
call crLibCr 'DSN.DBX's1'.DD1'
call crLibCr 'DSN.DBX's1'.DD2'
call crLibCr 'DSN.DBX's1'.EXE'
call crLibCr 'DSN.DBX's1'.REC'
call crLibCr 'DSN.DBX's1'.RE1'
call crLibCr 'DSN.DBX's1'.RDL'
call crLibCr 'DSN.DBX's1'.AOPT'
call crLibCr 'DSN.DBX's1'.QUICK'
end
return 0
endProcedure crLib
crLibCr: procedure expose m.
parse arg lib
call dsnAlloc lib'(DUMMY) dd(l1)' ,
'::f mgmtClas(COM#A076) space(1000, 1000) cyl'
call tsoFree l1
return 0
endProcedure crLibCr
crLibRe: procedure expose m.
parse arg lib, old
if sysDsn("'"old"'") <> "OK" then
return crLibCr(lib)
call adrTso "rename '"old"' '"lib"'"
return 0
endProcedure crLibRe
/*--- create the necessary dbx libries in the specified rz -----------*/
cpDum: procedure expose m.
parse arg rz subs
call cpDum1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.AUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.CDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call cpDum1 rz, 'DSN.DBX.JCL(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.MASK(DUMMY)'
call cpDum1 rz, 'DSN.DBX.OVRCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
*/call cpDum1 rz, 'DSN.DBX.DDL(DUMMY)'
if rz = 'RZ1' then
call cpDum1 rz, 'DSN.DBX.RENAMDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.GLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call cpDum1 rz, 'DSN.DBX's1'.ANA(DUMMY)',
, 'DSN.DBXDBAF.ANA(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.REC(DUMMY)',
, 'DSN.DBXDBAF.REC(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.DDL(DUMMY)',
, 'DSN.DBXDBAF.DDL(DUMMY)'
end
return 0
endProcedure cpDum
cpDum1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???cpDum' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
endProcedure cpDum1
renExeDsns: procedure expose m.
parse arg ana, dbsy
if length(ana) <> 8 then
call errHelp 'bad analysis' ana 'for ren'
if length(dbsy) <> 4 then
call err 'bad dbSystem' dbSy 'for ren'
if ana = m.edit.member then do
call memberOpt
call analyseAuftrag
ana = overlay(m.e.nachtrag, ana, 8)
end
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
/*say 'y' ly 'l' last 'dsn' m.csi.cx */
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = m.ut.alfUC
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
return 0
endProcedure renExeDsns
/*--- die Konfiguration pro db2 dbSy -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, dbSy
call configureRZ rz
call configuredbSy rz, dbSy
return
endProcedure configureRZSub
configureDbSy: procedure expose m.
parse arg rz, dbSy
call mapPut e, 'subsys', dbSy
if rz = 'RZX' then
call mapPut e, 'location', 'CHROI00X'dbSy
else if rz = 'RZY' then
call mapPut e, 'location', 'CHROI00Y'dbSy
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'dbSy
else
call mapPut e, 'location', 'CHSKA000'dbSy
return
endProcedure configureDBSy
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.promD.1)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.promD.1, rx+4, 4)
call mapPut e, 'schenv', 'DB2ALL'
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rz = m.myRz then
call mapPut e, 'csmDD'
else
call mapPut e, 'csmDD', ",(SUBSYS=(CSM,'SYSTEM="rz"'))"
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PB')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', 'DB2@.'zz'.'px'.DSNLOAD'
if toolV \== '' then
m.e.toolVers = toolV
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* toolV = copies(m.e.toolVers, rz == 'RZ1') */
toolV = m.e.toolVers
toolRZAl = zz'.'if(toolV == '', 'P0', toolV)
if m.lastSaidToolV \== substr(toolRzAl, 5) then do
m.lastSaidToolV = substr(toolRzAl, 5)
say 'tool version unter Alias' toolRzAl,
if(substr(toolRzAl, 5) =='P0', '==> v16')
end
call mapPut e, 'capref', 'DSN.CADB2.'toolRzAl
call mapPut e, 'caload', 'DSN.CADB2.'toolRzAl'.CDBALOAD'
call mapPut e, 'cacr', DBX
if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'e}dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'e}Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt, ai
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ4' then
if m.myRz = 'RZ1' then
call err 'dbx wurde ins RZ4 gezuegelt'
else
call err 'Auftrag für RZ' rz 'muss aus RZ4 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if wordPos(make, 'C W') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn, ai
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if ai \== '' then do
call sqlUpdate 7, 'update' m.aTb "set workliste='"nn"'" ,
", chg='"make"'",
"where workliste='' and pid ='"m.ai.pid"'" ,
" and name ='"m.ai.name"'"
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
cChgs = 'ALLLALLL'
iChgs = 'QZ91S2T'
end
else do
ow = 'S100447'
end
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
if ai == '' then do
/* loops in 2015 and later ......
zglS = '20130208 20130510 20130809 20131108' ,
'20140214 20140509 20140808 20141114 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
*/ zglSchub = '---'
best = 'pid name tel'
end
else do
zglSchub = m.ai.einfuehrung m.ai.zuegelschub
best = strip(m.ai.pid) strip(m.ai.name)
end
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller ' best ,
, ' cChgs ' cChgs ,
, ' iChgs ' iChgs ,
, ' keepTgt 0 '
if abbrev(auftName, 'VV') | abbrev(auftName, 'VDPS') then
call mAdd auftrag ,
, ' * ---------- Achtung VDPS -------------------------|' ,
, ' * nach jeder Aenderung alle anderen aktuellen |' ,
, ' * VDPS Auftraege Comparen (= DDL akutalisieren) |'
call mAdd auftrag ,
, 'source RZX/DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%'
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- naechsten Auftrag aus Auftragstabelle --------------------------*/
nextAuftragFromATb: procedure expose m.
parse arg pre, make, srch
srch = '%'translate(strip(srch))'%'
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where workliste = '' and pid not like 'ADMI%' and (" ,
"translate(pid) like '"srch"'" ,
"or translate(name) like '"srch"')" , ai
if m.ai.0 = 1 then
ax = 1
else if m.ai.0 < 1 then
call err 'e}kein Auftrag like' srch 'gefunden'
else do forever
say m.ai.0 'auftraege like' srch
do ax=1 to m.ai.0
say ax m.ai.ax.pid m.ai.ax.name m.ai.ax.einfuehrung ,
m.ai.ax.zuegelschub
end
say 'welcher Auftrag? 1..'m.ai.0 'oder - fuer keinen'
parse pull ax .
if strip(ax) == '-' then
return ''
if verify(ax, '0123456789') = 0 & ax > 0 & ax <= m.ai.0 ,
& symbol('m.ai.ax.zuegelschub') == 'VAR' then
leave
say 'ungueltige Wahl:' ax
end
return nextAuftrag(pre, make, , 'AI.'ax)
endProcedure nextAuftragFromATb
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', m.e.auf7 || m.e.nachtrag
if m.e.qCheck == 0 then nop
else if m.sysRz \== 'RZ1' & m.sysRz \== 'RZ4' then
say 'no quality check from' m.sysRz
else do
qx = m.scopeSrc.rz'/'m.scopeSrc.dbSy
px = m.promPath
qy = word(m.promD.px, words(m.promD.px))
if qualityCheck(qx, qy) then do
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 0
call adrIsp 'vput' vAns 'shared'
ddlxP = substr(m.auftrag.member, 8, 1)
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
call adrIsp "view dataset('"qDsn"'),
macro(ddlX) parm(ddlxP)",4
call adrIsp 'vget' vAns 'shared'
if pos('F', opts) < 1 & \ m.auftrag.force ,
& value(vAns) \== 1 then
return
else
say 'Compare trotz Qualitaetsfehlern'
end
end
m.o.0 = 0
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.dbSy, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast m.e.auf7 || nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast m.e.auf7 || nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
call mapPut e, 'keepTgtV', copies('KEEPTGT,', m.e.keepTgt)
if m.e.tool == ca then
call caDDL o, scopeSrc, translate(mapExp(e, m.e.cChgs))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeSrc.rz'/'m.scopeSrc.dbSy ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat","DDL") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- in the qualityMember say dbx c
to continue processing without option -f ------------------*/
qualityOk: procedure expose m.
parse arg fun
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 1
call adrIsp 'vPut' vAns 'shared'
return 0
endProcedure qualityOk
/*--- find the naming convention for a rz and dbSystem --------------*/
namingConv: procedure expose m.
parse arg rz, dbSy, var
if rz = '.' then do
if pos('.', dbSy) > 0 then
call err 'namingConv old target' dbSy
if pos('/', dbSy) > 0 then
parse var dbSy rz '/' dbSy
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(dbSy)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', m.o.
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh . , a1 a2
call analyseAuftrag
if length(wh) > 2 then do
llq = wh
end
else do /* abbrev: first or first and last character */
ll = ' ANA AN1 AOPT DDL DDI DD1 DD2 EXE EXO' ,
'JCL QUALITY QUICK REC RE1 RDL START'
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then do
d = '* .JCL' m.e.auftrag
end
else if llq == 'QUALITY' | LLQ == 'DDL' then do
d = '* .'llq m.e.auf7 || left(a1 || m.e.nachtrag, 1)
end
else if llq == 'EXO' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
msk = r2'/DSN.DBY'd2'.'m.e.auf7'*.**.EXE'
if dsnList(oo, msk, 0) < 1 then do
say 'no datasets like' msk
return
end
do ox=1 to m.oo.0
d1 = m.oo.ox
d2 = substr(d1, pos('.', d1, 19)+1)
if ox=1 | abbrev(d2, '##DT') ,
| (d2 > dMi2 & \ abbrev(dMi2, '##DT')) then do
dMax = d1
dMi2 = d2
end
end
d = r2 dMax
end
else if llq == 'START' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 'DSN.DBY'd2'.'m.e.auf7'.'llq
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
if llq == 'DDI' then
llR = 'DDL'
else
llR = llq
d = r2 d2'.'llR m.e.auf7 || n2
end
parse var d rz dsn mbr
if length(dsn) <= 20 then
dsn = m.libPre || dsn
eFun = word('Edit View', 1 + (fun \== 'E'))
if llq = 'QUALITY' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wordPos(llq, 'ANA AN1 REC RE1 EXO') > 0 then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"dsn ,
|| copies("("mbr")", mbr<>'')"')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"dsn"')",
copies("member("mbr")", mbr <> '') mac, 4
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call setIf jOut
call setIf jOut'.TWO'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = a2rzDbSysProm(rzDbSyList)
done = ''
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' dbSy
if opt == '*' then do
nachAll = m.compares
end
else if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if fun = 'IE' & (r == 'RZ2' ,
| (r == 'RZ4' & \ (abbrev(m.e.auftrag, 'Q') ,
|abbrev(m.e.auftrag, '@E') ,
|abbrev(m.e.auftrag, 'WK')))) then
call err 'ie fuer Prod nicht erlaubt:' r'/'dbSy
if m.e.tool = 'CA' then
nachAll = right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
if trgNm = '' then
call err 'compare not found for nachtrag' nachAll
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelN8, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs
else
call mapPut e, 'change',m.e.auftrag':'nachAll'/' ,
|| m.imp.seq'_'zs
call mapPut e, 'change', chaPre'.'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rzDbSys
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', m.e.auf7 || right(nachAll, 1)
done = done rzDbSys
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureDbSy r, dbSy
if m.e.tool == 'CA' then
call caImport jOut, fun, nachAll,
, translate(mapExp(e, m.e.iChgs)),
, translate(mapExp(e, m.e.iMap)),
, translate(mapExp(e, m.e.iRule))
else
call ibmImport jOut, fun, r, dbSy, nachAll,
, translate(mapExp(e, m.e.impMask)),
, translate(mapExp(e, m.e.impIgno))
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fu2)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
call addJobError jOut
call writeSub jOut
sq = ''
if m.e.zuegelN8 \== '' then do
today = translate('78.56.1234', date('s'),'12345678')
do dx=1 to words(done)
d1 = word(done, dx)
if symbol('m.promI.d1') \== 'VAR' then
call warn 'no col for' d1 'in AuftragsTable' m.aTb
else
sq = sq"," word(m.promI.d1, 1) "= '"today"'," ,
word(m.promI.d1, 2) "= '"m.uII"'"
end
end
if sq == '' then do
call warn 'zuegelSchub='m.e.zuegelSchub ,
'kein update in AuftragsTabelle' m.aTb
end
else do
call sqlConnect m.myDbSys
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'"
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'not in table' m.aTb
else if m.sql.1.updateCount \== 1 then do
call sqlUpdate 99, 'rollback'
call err 'auftrag' m.e.auftrag 'got' ,
m.sql.1.updateCount 'updateCount'
end
call sqlCommit
call sqlDisconnect
end
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
toRz = m.myRz
call mapPut e, 'toRz', toRz
if m.o.send.0 \== 0 & m.sysRz \== toRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.toRz.c1 \== 1 then do
m.cdlSent.toRz.c1 = 1
if sAft == '' then do
call mapPut e, 'cdl', dsnSetMbr(c1)
call addIf o
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIf o, 'end'
call setIf o, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
call addIf o
call mAddSt o, o'.TWO'
call addIf o, 'end'
m.o.ifLine = m.o.two.ifLine
end
else do
call addIf o
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call addJobError o'.TWO'
call mAddSt o, o'.TWO'
call mAdd o, la
call addIf o, 'end'
call setIf o, 'SUB'toRz
end
m.o.two.0 = 0
call setIf jOut'.TWO'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o'.SEND', c1
end
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TWO', nachAll
return
endProcedure ibmImport
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
call addIf o
ic = skelStem('Imp')
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIf o, 'end'
call setIf o, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddC.1 = 1
ddC.2 = 2
ddC.3 = 'L'
ddlIx = 3 - (iChgs \== '') - m.e.anapost
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib|| ddC.ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddC.ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddlBB
end
call addIf o'.TWO'
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly == '') ,
copies('keepTgt0', m.e.keepTgt == 0) ,
copies('anaPost0', m.e.anaPost == 0)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AOPT'
call mapPut e, 'stry', nact
call addIf o'.TWO'
call stepGroup
ddlImp = ddlLib'L('nact')'
if m.e.anaPost then do
call mapPut e, 'ddlIn', ddlAA
call mapPut e, 'ddlOut', ddlImp
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'PRE'
call addIf o'.TWO'
end
call mapPut e, 'ddlin', ddlImp
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AUTO'
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
call stepGroup
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
if m.e.aUtil = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' m.e.aUtil' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
call addIf o'.TWO'
call mapExpAll e, o'.TWO', skelStem('CAna')
if m.e.anapost then do
call mapExpAll e, o'.TWO', skelStem('CPost')
call setIf o'.TWO', 'ANA', 0 4, 'POST'
end
else do
call setIf o'.TWO', 'ANA', 0 4
end
call addIf o'.TWO', 'end'
call addIf o'.TWO'
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
oldIf = m.o.two.ifLine
call setIf o'.TWO'
call mapPut e, 'fun', 'execute'
call mapExpAll e, o'.TWO', skelStem(m.jobcard)
call mAdd o'.TWO', '//* Zuegelschub' m.e.zuegelschub k,
, '//* analyse ' date(s) time() m.uNa ,
, '//* nachtrag ' m.e.nachtrag m.e.auf7 || m.e.nachtrag,
, '//* rename old unloads: TSO DBX' m.e.auf7||m.e.nachtrag,
"REN" mapGet(e, 'subsys')
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call mAdd o'.TWO', '}!'
call addIf o'.TWO', 'end'
m.o.two.ifLine = oldIf
call stepGroup old
call setIf o'.TWO', 'EXCP', 0 4
end
if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'EXE', 0 4
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIf o, 'end'
call setIf o, 'DDL', 0 4
call addIf o
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
call addIf o
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
if m.o.ifLine == ''then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o,'// ENDIF' /* for if in skel dbxCRen */
call setIf o, 'RANA', 0 4
return
endProcedure caImpRename
stepGroup: procedure expose m.
parse arg f
old = m.e.stepNo
if f \== '' then
no = f
else
no = old + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return old
endProcedure stepGroup
setIf: procedure expose m.
parse arg o, stp, codes
if stp == '' | m.e.tool = 'IBM' then
li = ''
else do
li = ''
do ax=2 by 2 to arg()
stp = arg(ax)
codes = arg(ax+1)
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = li 'AND' stp'.RUN AND'
if codes == '' then
li = li stp'.RC=0'
else if words(codes) = 1 then
li = li stp'.RC='strip(codes)
else do
li = li '('stp'.RC='word(codes, 1)
do cx=2 to words(codes)
li = li 'OR' stp'.RC='word(codes,cx)
end
li = li')'
end
end
li = substr(li, 6)
end
m.o.ifLine = li
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt, cond
if m.o.ifLine == '' & opt \== 1 then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else do
pr = '// IF'
if cond == '' then
cond = m.o.ifLine
cond = space(cond, 1)
do while length(cond) > 53
ex = lastPos(' ', left(cond, 53))
call mAdd o, pr left(cond, ex-1)
cond = substr(cond, ex+1)
pr = left('//', length(pr))
end
call mAdd o, pr cond 'THEN'
end
return
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if cond = '' then
cond = 'RC=0'
call addIf o, 1, 'ABEND OR RC > 4 OR NOT (' cond ')'
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.anaPost = 1
m.e.ddlOnly = 0
m.e.zuegelschub = ''
m.e.aOpt = ''
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER ICHGS IMPMASK IMAP IRULE IMPIGNO'
varWu = 'CCHGS COMMASK COMIGNO' ,
'AOPT AMODEL AUTIL VP0 VP1 VP2 VP3 VP4 VPT VP16 VP17' ,
'KEEPTGT DBACHECK QCHECK CA BMC IBM DDLONLY ANAPOST'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.auf7 = left(w2, 7)
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.e.anaPost = m.e.anaPost == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
if m.e.ddlOnly == '' | m.e.ddlOnly == 1 then
m.e.ddlOnly = ''
else
m.e.ddlOnly = 'UNLOAD'
if m.e.cChgs == '' then
m.e.cChgs = 'PROT'm.e.prodDbSys
if m.e.iChgs == '' then
m.e.iChgs = dsnGetMbr(m.e.impMask)
else if m.e.impMask == '' then
m.e.impMask = m.libPre'.MASK('m.e.iChgs')'
if m.e.iRule == '' then
m.e.iRule = dsnGetMbr(m.e.impIgno)
else if m.e.impIgno == '' then
m.e.impIgno = m.libPre'.MASK('m.e.iRule')'
call mapPut e, 'aModel', m.e.aModel
zt = translate(m.e.zuegelschub, '000000000', '123456789')
if zt == '00.00.0000' then do
m.e.zuegelN8 = translate('67893401', m.e.zuegelSchub,
,'0123456789')
end
else if zt == '00000000' then do
m.e.zuegelN8 = m.e.zuegelSchub
m.e.zuegelschub = translate('78.56.1234', m.e.zuegelN8,
,'12345678')
end
else do
m.e.zuegelN8 = ''
end
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.dbSy, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop dbSy
say ' scope ' m.scp.0 m.scp.dbSy ,
' target ' m.scopeTrg.0 m.scopeTrg.dbSy
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
sayImp: procedure expose m.
do ix=1 to m.imp.0
say 'imp' m.imp.ix.nachtrag 'to' m.imp.ix.rz'/'m.imp.ix.dbSys
end
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureDbSy m.scopeTrg.rz, m.scopeTrg.dbSy
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- create jcl to copy one member to rz toRz and library toLib -----*/
copyMbr: procedure expose m.
parse arg o, mbr, frLib, toRz, toLib
call mapPut e, 'mbr', mbr
call mapPut e, 'frLib', dsnSetMbr(frLib)
call mapPut e, 'toRz', toRz
call mapPut e, 'toLib', dsnSetMbr(toLib)
call addIf o
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIf o, 'end'
call setIf o, 'COPY', 0
return
endProcedure copyMbr
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlConnect m.scp.dbSy
else
call sqlConnect m.scp.rz'/'m.scp.dbSy
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
trace ?r
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
removeQualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure removeQualityCheck
/*--- Qualitaets Pruefung mittels ddlCheck ---------------------------*/
qualityCheck: procedure expose m.
parse arg x, y
m.spezialFall.done = ''
lst = ''
scp = 'SCOPESRC'
o = 'AUFTRAG'
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then
f1 = 'db:'m.sn.name
else if m.sn.Type = 'TS' then
f1 = 'ts:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'TB' then
f1 = 't:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'VW' then
f1 = 'v:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'IX' then
f1 = 'i:'m.sn.qual'.'m.sn.name
else
iterate
f1 = space(f1, 0)
if wordPos(f1, lst) > 0 then
iterate
lst = lst f1
end
m.o.orig = 'rmQu' m.o.orig
if lst = '' then do
say 'qualitycheck no objects to check'
call mAdd o, '|| qualitycheck no objects to check'
return 0
end
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
cRes = ddlCheck('CHECK' qDsn x y lst)
call splitNl cr, cRes
cr1 = substr(m.cr.1, 4)','
if pos('\n', cRes) > 0 then
cr1 = left(cRes, pos('\n', cRes)-1)','
else
cr1 = cRes','
res = pos('q,', cr1) > 0 | pos('*sb,', cr1) > 0 ,
| pos('*p', cr1) > 0 | pos('*n,', cr1) > 0 ,
| pos('special', cr1) > 0 | pos('*-,', cr1) > 0
if \ res then do /* add new | lines to auftrag */
call mAdd o, '|| qualitycheck ok:' substr(m.cr.1, 4)
end
else do
call mAdd o, '|| qualitycheck:' substr(m.cr.1, 4)
call mAddSt o, cr, 2
end
return res
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
removeSspezialFall: procedure expose m. --> ddlCheck
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-' left(m.st.sx, 78)
end
return
endProcedure removeSpezialFall
/*--- mask handling initialise ---------------------------------------*/
removemaskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
removemaskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
removetestMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
removeMaskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
removemask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
removemaskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
removemaskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
removemaskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg dbSy
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & dbSy == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if dbSy = '' then
dbSy = if(subs2 == '', m.pr1Sub, subs2)
dbSy = translate(dbSy, '/', '.')
if abbrev(dbSy, m.sysRz'/') then
dbSy = substr(dbSy, 5)
call sqlConnect dbSy
dbSy = translate(dbSy, m.ut.alfLC, m.ut.alfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu dbSy) < 70 then
neu = left(neu, 68 - length(dbSy)) '*'dbSy
else if length(neu dbSy) < 80 then
neu = neu '*'dbSy
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(name)," ,
"case when nTables <> 1",
"then 'ty=' || type" ,
"|| ', ' || nTables || ' tables||| '",
"else value( (select 'tb '" ,
"|| strip(t.creator) ||'.'|| strip(t.name)",
"|| case when t.type = 'T' then ''" ,
"else ' ty=' || t.type end" ,
"from sysibm.systables t" ,
"where t.type not in ('A','V')" ,
"and t.dbName=s.dbName and t.tsName=s.name" ,
"), 'not found')" ,
"end" ,
"from sysibm.systableSpace s" ,
"where dbName" sqlClause(qu) "and name" sqlClause(nm)
/*???else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end" ,
"|| min(strip(creator) ||'.'|| strip(name))",
"|| case when count(*) = 1 and min(type) <> 'T'" ,
"then ' ty=' || min(type) else '' end" ,
"from sysibm.systables" ,
"where type not in ('A','V')" ,
"and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName" ???????????*/
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case type when 'V' then 'vw'",
"when 'A' then 'al' else 'tb' end," ,
"strip(creator) || '.' || strip(name)" ,
"|| case when type <> '"left(ty, 1)"'" ,
"then ' ty=' || type else '' end," ,
"case when type = 'A' then 'for '" ,
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type" if(ty=='TB', "not in ('A', 'V')" ,
, "= '"left(ty, 1)"'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IS' then
sql = "select 'is', strip(dbName) ||'.'|| strip(indexSpace),",
"'tb ' || strip(tbCreator)|| '.' || strip(tbName)" ,
" || ' ix ' || strip(name)" ,
'from sysibm.sysIndexes' ,
'where dbname' sqlClause(qu),
'and indexSpace' sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', 'FT FN FI'
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = m.e.auf7 || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' oDsn)
call caDD1 o, scp, GlbChg, oDsn
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg, ddlOut
call mapPut e, 'user', userid()
call mapPut e, 'ddlOut', ddlOut
call mapExpAll e, o, skelStem('CCOM')
call mapPut e, 'comm', mapExp(e, 'dbx $fun',
copies('recover', pos('.RDL(', ddlOut) > 0)'DDL' ,
'$AUFTRAG $NACHTRAG')
if abbrev(scp, '//') then
call mAdd o, scp, '// DD *'
else do sx=1 to m.scp.0
call rcmQuickAdd o, m.scp.sx.type, m.scp.sx.qual, m.scp.sx.name
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".GlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.dbSy \== m.scopeTrg.dbSy then
call err 'bmc compare on different dbSystems not implemented'
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlConnect m.scp.dbSy
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
zglSchub: procedure expose m.
parse arg fun rest
if length(fun) = 4 & datatype(fun, 'n') then
parse arg zgl fun rest
else
zgl = substr(date('s'), 3, 4)
only18 = fun == 18
if only18 then
parse var rest fun rest
if fun = '' then
call err 'zglSchub kein Fun fuer Auftraege:' arg(1)
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
copies("and einfuehrungs_zeit = '18:00'", only18) , zsa
call sqlDisconnect
do zx=1 to m.zsa.0
if m.zsa.zx.workliste = '' then
iterate
say zx m.zsa.zx.workliste m.zsa.zx.auftrag ,
m.zsa.zx.einfuehrungs_zeit m.zsa.zx.id7
call work m.zsa.zx.workliste fun rest
end
endProcedure zglSchub
/*--- zStat Zuegelschub Statistik ------------------------------------*/
zstat a? yymm? - in rz4, create AyyMM mit AuftragsListe
----------------------------------------------------------------------*/
zStat: procedure expose m.
parse upper arg aArg
parse upper arg fun zgl
rz = sysvar('sysNode')
if fun = '' then
if rz = 'RZ4' then
fun = 'A'
else if rz = 'RZ2' | rz = 'RR2' | rz = 'RQ2' then
fun = 'S'
z0 = translate(zgl, '000000000', '123456789')
if zgl = '' then
z1 = substr(date('s'), 3, 4)
else if z0 == '0000' then
z1 = zgl
else if z0 == '000000' then
z1 = substr(zgl, 3)
else if z0 == '00.00.00' then
z1 = translate('5634', zgl, '12.34.56')
else
call err 'bad Zugelschub should be yymm or dd.nn.yy not' zgl
aDsn = m.libPre'.ZGL(ZSTA'z1')'
sDsn = m.libpre'.ZGL(ZSTS'z1')'
if fun = 'A' then do
if rz <> 'RZ4' then
call err 'zstat a... only in rz4'
if sysDsn("'"aDsn"'") == 'OK' then
call err "e}"aDsn "existiert schon"
call zStatAuftragsListe z1, m.libPre'.auftrag', aDsn
end
else if fun == 'S' then do
if rz <> 'RZ2' & rz <> 'RR2' & rz <> 'RQ2' & rz <> 'RZ4' then
call err 'zstat s... only in rz2 or rz4'
if sysDsn("'"aDsn"'") \== 'OK' then
call err aDsn "existiert nicht"
call zStatsStatistik z1, aDsn, sDsn
end
else
call err 'i}bad fun' fun 'in arguments zStat' aArg
return 0
endProcedure zStat
zStatAuftragsListe: procedure expose m.
parse arg zgl, lib, outDsn
zg2 = '20'zgl
zg3 = translate('.34.12', zgl, '1234')
zg4 = translate('.cd.20ab', zgl, 'abcd')
call sqlConnect m.myDbSys
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
/* copy ii end ********* Installation Info *************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
m.m.0 = mx
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
m.m.0 = mbr_name.0
end
return mx
endProcedure mbrList
/*--- return wheter a dsn exists ------------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
----------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse arg fr, to, mbrs
if mbrs \== '' then do
if dsnGetMbr(fr) \== '' | dsnGetMbr(to) \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if words(mbrs) == 1 then do
parse value strip(mbrs) with old '>' new
if old = '' then
call err 'bad mbr old/new' mbrs
fr = dsnSetMbr(fr, old)
to = dsnSetMbr(to, word(new old, 1))
mbrs = ''
end
end
/* currently we do everything with csm
if the need arises, implement tso only version */
return csmCopy(fr, to, mbrs)
endProcedure dsnCopy
dsnDelete: procedure expose m.
parse arg aDsn
parse value dsnCsmSys(aDsn) with sys '/' dsn
if sys \== '*' then
return csmDel(sys, dsn)
if adrTso("delete '"dsn"'", 8) == 0 then
return 0
if pos('IDC3330I **' dsnGetMbr(dsn)' ', m.tso_trap) >= 1 then
say 'member not found and not deleted:' dsn
else if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then
say 'dsn not found and not deleted:' dsn
else
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDelete
/* copy dsnList end ************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn
if dsnGetMbr(dsn) == '' then do
if adrCsm("allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)", 8) == 0 then do
call adrTso 'free dd(del1)'
return 0
end
if pos('CSMSV29E DATA SET' dsn 'NOT IN CAT', m.tso_trap) > 0,
then do
say 'dsn not found and not deleted:' rz'/'dsn
return 4
end
end
else do
if adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8) == 0 then
return 0
if pos('CSMEX77E Member:'dsnGetMbr(dsn) 'not f', m.tso_trap) ,
> 0 then do
say 'member not found and not deleted:' rz'/'dsn
return 4
end
end
return err('csmDel rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(fr) \== ''
toMbr = dsnGetMbr(to) \== ''
call csmAlloc fr, frDD, 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
/*??if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr) ???????? */
call csmAlloc to, toDD, 'shr', , ':D'frDD
/* if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end ?????????????? */
inDD = tsoDD('csmIn*', 'a')
i.0 = 0
if mbrs \== '' then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
else if \ frMbr & m.tso_dsOrg.frDD == 'PO' then do
call adrCsm "mbrList ddName("frDD") index(' ') short"
i.0 = mbr_mem#
do ix=1 to i.0
i.ix = ' S M='mbr_name.ix
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*"
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do /* copy output to stem */
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead return sqlRdrRead(m)")
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead return sqlRdrRead(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
return sqlsOut(scanSqlStmtRdr(sqlSrc, opt), retOk, 'a')
endProcedure sqlStmts
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrRead: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrRead
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then
return err('??? old interface') / 0
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
m.m.bufI0 = m.m.bufI0 + m.m.buf.0
m.m.readIx = 0
interpret objMet(m, 'jRead')
ix = 1
if m.m.buf.0 < ix then
return err('jRead but no lines') / 0
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
interpret objMet(m, 'jWrite')
return
endProcedure jWrite
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.bufMax = 0
return m
endProcedure jReset
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
call jReset0 m, arg, arg2, arg3
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
/*--- text for a method, for buffer of size 1 only ------------------*/
jWrite1Met: procedure expose m.
parse arg f1
return "jWrite if m.m.buf.0\==1 then call err 'bad jWrite1Met';" ,
"var = m'.BUF.1'; m.m.buf.0 = 0;" f1
/*--- text for a method, for buffer
jWriteBMet: procedure expose m.
parse arg f1, fe
return "jWrite" ,
copies("do wx=1 to m.m.buf.0;" ,
"var = m'.BUF.'wx;" f1"; end;", f1 <> '') ,
copies("vBu = m'.BUF';" fe";", fe <> ''),
"m.m.bufI0 = m.m.bufI0 + m.m.buf.0; m.m.buf.0 = 0"
------------------*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "new return 'm = jReset0('classMet(cl, 'new2')');'" ,
"classMet(cl, 'jReset')'; return m'" )
/* "new ?r m = jReset0(?new2); ?jReset; return m" */
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
cDe= classNew('n JRWDelegLazy u LazyRoot', 'm',
, "new return 'return jReset('classMet(cl, 'new1')', arg)'" )
/* , "new ?r return jReset(?new1, arg)", */
c2 = classNew('n JRWDeleg u JRW', 'm',
, "METHODLAZY" cDe,
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, jWrite1Met(" say o2Text(m.var, 157)"),
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose" ,
, "jRead return 0",
, "jWrite call err 'buf overflow",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
call classNew "n JbufText u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = word(arg 80, 1)",
, "jWrite call jBufWrite m, o2Text(line, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jBufText: write text descriptions -----------------------------*/
jbufText: procedure expose m.
m = oNew('JbufText') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = o2text(arg(ax))
end
m.m.buf.0 = ax-1
return m
endProcedure jbufText
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
m.m.bufMax = 1e30
if opt == m.j.cWri then do
m.m.buf.0 = 0
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
m.m.buf.0 = ax
return m
endProcedure jBufWriteStem
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.s2c., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj ---------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
r = m'=¢'
do fx=1 to m.cl.flds.0 while length(r) <= maxL
f1 = m.cl.flds.fx
c1 = m.cl.f2c.f1
if c1 = m.class_V then
op = '='
else if m.c1 == 'r' then
op = '=>'
else
op = '=?'c1'?'
r = r || left(' ', fx > 1) || m.cl.flds.fx || op
if m.cl.flds.fx == '' then
r = r || strip(m.m)
else
r = r || strip(mGet(m'.'m.cl.flds.fx))
end
if length(r) < maxL then
return r'!'
else
return left(r, maxL-3)'...'
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, met
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
return 'return o2TextFlds(m, '''cl''', maxL)'
endProcedure o2TextGen
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "o2Text return o2textGen(cl)",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new return 'return' classMet(cl, 'new2')",
, "new1 call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'oMutate(mNew('''cl'''), '''cl''')'" ,
, "new2 call classMet cl, 'oClear';" ,
"return 'classClear('''cl''','" ,
"classMet(cl, 'new1')')'" ,
, "oClear return classClearGen(cl)" ,
, "oCopy return oCopyGen(cl)")
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
/* 'o2Text ?r return m"=¢?:!"' */
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, 'o2String return m')
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
laRun = classNew('n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''")
/* 'o2Text ?r return m"=¢?:!"' */
call classNew 'n ORun u', 'm',
, 'METHODLAZY' laRun ,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively -------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldGen: procedure expose m.
parse arg cl
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
classClearGen: procedure expose m.
parse arg cl
call classMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
dProcedure classClearGen
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
dd = tsoDD(dd, 'a')
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/ 6
}¢--- A540769.WK.REXX(DBXCALL) cre=2015-11-16 mod=2015-11-23-10.26.42 A540769 ---
/* rexx ***************************************************************/
parse arg a
address tso "exec 'dsn.db2.exec(dbx)'" quote(a, "'")
exit
/*--- 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
}¢--- A540769.WK.REXX(DBXCMP) cre=2010-07-30 mod=2010-08-05-18.16.26 A540769 ---
$=di=DSN.DBX.SRCCAT(ZZCMP020)
$=do=DSN.DBX.SRCCAT(ZZCMP02Z)
ic = 0
oc = 0
call dsnAlloc 'dd(ddi)' $di
call dsnAlloc 'dd(ddo)' $do
do while readDD(ddi, i.)
ox = 0
do ix=1 to i.0
ic = ic + 1
if substr(i.ix, 3, 20) \= 'F332163' then do
oc = oc + 1
ox = ox + 1
if ox \= ix then
i.ox = i.ix
end
end
i.0 = ox
call writeDD ddo, i.
end
call readDDEnd ddI
call writeDDEnd ddO
call adrTso 'free dd(ddi ddo)'
$$- 'in' ic 'out' oc
$#out 20100805 16:39:01
in 89255 out 89184
$#out 20100730 18:01:06
in 89255 out 89184
$#out 20100730 17:52:02
in 89255 out 89184
$#out 20100730 17:49:49
$#out
$#out 20100730 17:49:32
}¢--- A540769.WK.REXX(DBXEXE) cre=2016-01-19 mod=2016-01-19-12.36.20 A540769 ---
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.1
19. 1.16
edit macro fuer CS Nutzung von CA RCM
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr us naechsten Auftrag ab Tabelle erstellen
aa: anzueigen, aw, ac entsprechendes Member editieren
n,na,nc,nt neuen Auftrag erstellen (nt = test)
q dbSy? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren, sonst Alle
* funktioniert nicht nur in Auftrag
* dbSy hier wird gesucht sonst in source
c op1? create ddl from source
i | ia | ie subs nct changes in Db2Systeme importier(+ana+exe)
subs = sub(,sub)*: Liste von Stufen/rzDbSys
sub: RR2/DBOF (im PTA), RZY(betr. dbSy)
X, Y, Z, Q, R, P, UT, ST, SIT, IT Abkuerzungen
==> sucht im PromotionPath
nct: Nachtrag: leer=noch nicht importiert sonst angegeb
8: Nachtrag 8, *: neuster, =: wie letztes Mal
v* ¦ e* rzDb? nt?: view/edit ana,cdl,ddl,exe etc. locally or remote
* ist der llq oder Abkuerzung: a->ana, a1->an1
rzDb gibt rz und dbsys: rzz/de0g, ze, z, etc
nt Nachtrag, sucht neuest Import mit diesen Bedingunen
ren dbSy rename DSNs der Execution der Analyse in DBSystem
z 18? fun args fuer alle Auftraege / 18:00 Auftraege des ZglSchubs
zStat Zuegelschub Statistik siehe wiki help
opt* Optionale Optionen
-f force: ignoriere QualitaetsVerletzungen
oder dbx c im QualitaetsMember
-aAuft oder Auft: AuftragsMember oder DSN
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: vPT VP*, keeptgt 0, qCheck 0, dbaCheck 0, ddlOnly 1
ca, bmc, ibm
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
wiki help http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Dbx
************************************************************************
19. 1.2016 Walter support sequence
*/ /* end of help
19.11.2015 Walter remote edit, anaPre .......
8. 6.2015 Walter kidi63 ==> klem43
8. 9.2014 Walter warning falls ungueltiger ZS und kein update tadm70
29. 8.2014 Walter RQ2 rein, RZ1 raus
14. 7.2014 Walter zstat in rq2
26. 5.2014 Walter dbx q: auch TS mit History Tabellen anzeigen
17. 3.2014 Walter zstat: zuegelschub Datum korrigiert
18. 2.2014 Walter Integration in auftragsTable
23.12.2013 Walter dbx q findet tables mit type<>T, wieder csm.div
4.12.2013 Walter zStat macht nur Warnung wenn ana <> auftrag
25.10.2013 Walter move rz8 --> rzx
2.10.2013 Walter rename Analysis in ZielRz nicht RZ4 wegen Release
27. 9.2013 Walter move to rz4
26. 9.2013 Walter promotePaths UT,ST,SIT,x,y,z, nachtrag *
23. 9.2013 Walter vp0/1/2/3/4/16/17 + vp0=default
16. 9.2013 Walter Nachtraege in zSTat geflickt
2. 9.2013 Walter ueberall class=log (auch PTA|)
30. 8.2013 Walter vP17 fuer CA Tool Version 17
19. 8.2013 Walter zstat in rz4
9. 8.2013 Walter schenv pro rz in JobCard generiert
19. 7.2013 Walter qualityCheck fuer VW, kein Check wenn keine Objs
8. 7.2013 Walter zStat auch im RR2
28. 6.2013 Walter fix qualityCheck fuer Db
26. 6.2013 Walter dbx c in QualitaetsMember fuer Weiterarbeit ohne -f
25. 6.2013 Walter v2.4: zSta, Namen angepasst auf ca ...
11. 6.2013 W. Keller qualityCheck mit Verglich in RZ2 und vq
14. 5.2013 W. Keller VPT für tool Alias PT
07. 5.2013 W. Keller crLib with primary 1000 cyls (avoid alloc err)
03. 4.2013 W. Keller IA erstellt jetzt exeJcl in dsn.dbx<dbSys>.exe
07. 3.2013 W. Keller in neuem Auftrag: CA und VDPS Warnung
06. 2.2013 W. Keller ca scope fuer Triggers
31. 1.2013 W. Keller integration anaPost und start, variable auf7
24. 1.2013 W. Keller initial edit macro AC fuer CA Analysen
18. 1.2013 W. Keller caDdl->ddl, caGlbChg->glbChg ohne dbxRen.*
9. 1.2013 W. Keller ddlOnly fuer CA eingebaut
8.01.2013 W. Keller rename fuer CA eingebaut: dbx ni030121 ren dbaf
13.12.2012 W. Keller Fehler bei 1 stellig import (verwechslung nachtr)
7.12.2012 W. Keller .stry -> .ana, vy -> va etc.
5.12.2012 W. Keller ca implementation I
9.11.2012 W. Keller ey und vy für view/edit strategy
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset hi
call jIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.aTb = 'oa1p.tAdm70A1'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if 1 & oArgs = '' then do
oArgs = 'count ~tmp.text(qx010011)'
say 'testing' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
m.e.toolAlias = 'P0'
do forever
r = substr(fun, 1 + 2*abbrev(fun, '-'))
if abbrev(fun, '-A') | length(fun) >= 8 then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then
m.auftrag.force = 1
else if abbrev(fun, '-') then
call err 'bad opt' fun 'in' wArgs
else
leave
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = iiDS(org)'.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
end
if 0 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ1 then
m.myDbSys = DBAF
else if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
call mapPut e, 'rexxLib', 'DSN.DB2.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
call mapPut e, 'tst', date('s') time()
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if fun == 'Z' then
return zglSchub(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if fun = 'COUNT' then
return countAna(args)
if wordPos(fun, 'AA NC NW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if wordPos(fun, 'AC AW') > 0 then
return nextAuftragFromATb(word(args, 1),
, substr(fun, 2), word(args, 2))
else if fun = 'C' & m.editMacro,
& right(m.edit.dataset, 8) = '.QUALITY' then
return qualityOk(fun, args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
else if fun = 'CPDUM' then
return cpDum(args)
else if fun = 'CRLIB' then
return crLib(args)
else if fun = 'REN' then
return renExeDsns(m.auftrag.member, args)
else if fun = 'ZSTAT' then
return zStat(args)
call memberOpt
if m.sysRz <> 'RZ4' then
call err 'dbx laeuft nur noch im RZ4'
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if abbrev(fun, 'E') | abbrev(fun, 'V') then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
ii = 'Marc ma'
else if m.uId = 'A390880' then
ii = 'Martin sm'
else if m.uId = 'A540769' then
ii = 'Walter wk'
else if m.uId = 'A754048' then
ii = 'Alessandro ac'
else if m.uId = 'A790472' then
ii = 'Agnes as'
else if m.uId = 'A828386' then
ii = 'Reni rs'
else if m.uId = 'A586114' then
ii = 'Stephan sz'
else
ii = m.uId '??'
parse var ii m.uNa m.uII
m.e.toolVers = ''
m.scopeTypes = 'DB TS TB VW AL IS IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths neu */
m.promN = 'X Y Z Q R P'
m.promN_A = 'UT ST SI SIT ET IT PQ PA PR'
m.promN_T = 'X Y Z,Q Z,Q X Y,Z,Q Q R P'
m.promD.1 = 'RZX/DE0G RZY/DE0G RZZ/DE0G' ,
'RQ2/DBOF RR2/DBOF RZ2/DBOF'
m.promD.2 = 'RZX/DEVG RZY/DEVG RZZ/DEVG' ,
'RQ2/DVBP RR2/DVBP RZ2/DVBP'
m.promD.0 = 2
/* promI columns in auftragsTable aTb */
m.promI.0 = 0
call dbxI2 'UT RZX/DE0G DEVG UT_RZX_DE0G ID1'
call dbxI2 'ST RZY/DE0G DEVG ST_RZY_DE0G ID4'
call dbxI2 'SIT RZ1/DBTF DVTB SIT_RZ1_DBTF ID2'
call dbxI2 'SIT RZZ/DE0G DEVG SIT_RZZ_DE0G ID3'
call dbxI2 'PQA RQ2/DBOF DVBP PTA_RZQ_DBOF ID6'
call dbxI2 'PTA RR2/DBOF DVBP PTA_RR2_DBOF ID5'
call dbxI2 'PROD RZ2/DBOF DVBP PROD_RZ2_DBOF ID7'
m.lastSaidToolV = 'P0'
return
endProcedure dbxIni
dbxI2: procedure expose m.
px = m.promI.0 + 1
m.promI.0 = px
parse arg m.promI.px
parse arg e rzD1 d2 fDt fUs
m.promI.rzD1 = fDt fUs
rzD2 = left(rzD1, 4)d2
m.promI.rzD2 = fDt fUs
return
endProcedure dbxI2
/*--- create the necessary dbx libraries locally ---------------------*/
crLib: procedure expose m.
parse arg subs
rz = sysvar(sysnode)
call crLibCr 'DSN.DBX.AUFTRAG'
call crLibCr 'DSN.DBX.DDL'
call crLibCr 'DSN.DBX.GLBCHG'
call crLibCr 'DSN.DBX.JCL'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call crLibCr 'DSN.DBX's1'.ANA'
call crLibCr 'DSN.DBX's1'.AN1'
call crLibCr 'DSN.DBX's1'.DDL'
call crLibCr 'DSN.DBX's1'.DD1'
call crLibCr 'DSN.DBX's1'.DD2'
call crLibCr 'DSN.DBX's1'.EXE'
call crLibCr 'DSN.DBX's1'.REC'
call crLibCr 'DSN.DBX's1'.RE1'
call crLibCr 'DSN.DBX's1'.RDL'
call crLibCr 'DSN.DBX's1'.AOPT'
call crLibCr 'DSN.DBX's1'.QUICK'
end
return 0
endProcedure crLib
crLibCr: procedure expose m.
parse arg lib
call dsnAlloc lib'(DUMMY) dd(l1)' ,
'::f mgmtClas(COM#A076) space(1000, 1000) cyl'
call tsoFree l1
return 0
endProcedure crLibCr
crLibRe: procedure expose m.
parse arg lib, old
if sysDsn("'"old"'") <> "OK" then
return crLibCr(lib)
call adrTso "rename '"old"' '"lib"'"
return 0
endProcedure crLibRe
/*--- create the necessary dbx libries in the specified rz -----------*/
cpDum: procedure expose m.
parse arg rz subs
call cpDum1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.AUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.CDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call cpDum1 rz, 'DSN.DBX.JCL(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.MASK(DUMMY)'
call cpDum1 rz, 'DSN.DBX.OVRCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
*/call cpDum1 rz, 'DSN.DBX.DDL(DUMMY)'
if rz = 'RZ1' then
call cpDum1 rz, 'DSN.DBX.RENAMDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.GLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call cpDum1 rz, 'DSN.DBX's1'.ANA(DUMMY)',
, 'DSN.DBXDBAF.ANA(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.REC(DUMMY)',
, 'DSN.DBXDBAF.REC(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.DDL(DUMMY)',
, 'DSN.DBXDBAF.DDL(DUMMY)'
end
return 0
endProcedure cpDum
cpDum1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???cpDum' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
endProcedure cpDum1
renExeDsns: procedure expose m.
parse arg ana, dbsy
if length(ana) <> 8 then
call errHelp 'bad analysis' ana 'for ren'
if length(dbsy) <> 4 then
call err 'bad dbSystem' dbSy 'for ren'
if ana = m.edit.member then do
call memberOpt
call analyseAuftrag
ana = overlay(m.e.nachtrag, ana, 8)
end
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
/*say 'y' ly 'l' last 'dsn' m.csi.cx */
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = m.ut.alfUC
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
return 0
endProcedure renExeDsns
/*--- die Konfiguration pro db2 dbSy -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, dbSy
call configureRZ rz
call configuredbSy rz, dbSy
return
endProcedure configureRZSub
configureDbSy: procedure expose m.
parse arg rz, dbSy
call mapPut e, 'subsys', dbSy
if rz = 'RZX' then
call mapPut e, 'location', 'CHROI00X'dbSy
else if rz = 'RZY' then
call mapPut e, 'location', 'CHROI00Y'dbSy
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'dbSy
else
call mapPut e, 'location', 'CHSKA000'dbSy
return
endProcedure configureDBSy
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.promD.1)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.promD.1, rx+4, 4)
call mapPut e, 'schenv', 'DB2ALL'
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rz = m.myRz then
call mapPut e, 'csmDD'
else
call mapPut e, 'csmDD', ",(SUBSYS=(CSM,'SYSTEM="rz"'))"
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PB')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', 'DB2@.'zz'.'px'.DSNLOAD'
if toolV \== '' then
m.e.toolVers = toolV
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* toolV = copies(m.e.toolVers, rz == 'RZ1') */
toolV = m.e.toolVers
toolRZAl = zz'.'if(toolV == '', 'P0', toolV)
if m.lastSaidToolV \== substr(toolRzAl, 5) then do
m.lastSaidToolV = substr(toolRzAl, 5)
say 'tool version unter Alias' toolRzAl,
if(substr(toolRzAl, 5) =='P0', '==> v16')
end
call mapPut e, 'capref', 'DSN.CADB2.'toolRzAl
call mapPut e, 'caload', 'DSN.CADB2.'toolRzAl'.CDBALOAD'
call mapPut e, 'cacr', DBX
if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'e}dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'e}Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt, ai
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ4' then
if m.myRz = 'RZ1' then
call err 'dbx wurde ins RZ4 gezuegelt'
else
call err 'Auftrag für RZ' rz 'muss aus RZ4 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if wordPos(make, 'C W') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn, ai
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if ai \== '' then do
call sqlUpdate 7, 'update' m.aTb "set workliste='"nn"'" ,
", chg='"make"'",
"where workliste='' and pid ='"m.ai.pid"'" ,
" and name ='"m.ai.name"'"
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
end
else do
ow = 'S100447'
cChgs = 'PROT'if(abbrev(auftName, 'XB'), 'DVBP', 'DBOF')
iChgs = 'DBOF$impNm'
end
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
if ai == '' then do
/* loops in 2015 and later ......
zglS = '20130208 20130510 20130809 20131108' ,
'20140214 20140509 20140808 20141114 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
*/ zglSchub = '---'
best = 'pid name tel'
end
else do
zglSchub = m.ai.einfuehrung m.ai.zuegelschub
best = strip(m.ai.pid) strip(m.ai.name)
end
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller ' best ,
, ' cChgs ' cChgs ,
, ' iChgs ' iChgs ,
, ' keepTgt 0 '
if abbrev(auftName, 'VV') | abbrev(auftName, 'VDPS') then
call mAdd auftrag ,
, ' * ---------- Achtung VDPS -------------------------|' ,
, ' * nach jeder Aenderung alle anderen aktuellen |' ,
, ' * VDPS Auftraege Comparen (= DDL akutalisieren) |'
call mAdd auftrag ,
, 'source RZX/DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%'
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- naechsten Auftrag aus Auftragstabelle --------------------------*/
nextAuftragFromATb: procedure expose m.
parse arg pre, make, srch
srch = '%'translate(strip(srch))'%'
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where workliste = '' and pid not like 'ADMI%' and (" ,
"translate(pid) like '"srch"'" ,
"or translate(name) like '"srch"')" , ai
if m.ai.0 = 1 then
ax = 1
else if m.ai.0 < 1 then
call err 'e}kein Auftrag like' srch 'gefunden'
else do forever
say m.ai.0 'auftraege like' srch
do ax=1 to m.ai.0
say ax m.ai.ax.pid m.ai.ax.name m.ai.ax.einfuehrung ,
m.ai.ax.zuegelschub
end
say 'welcher Auftrag? 1..'m.ai.0 'oder - fuer keinen'
parse pull ax .
if strip(ax) == '-' then
return ''
if verify(ax, '0123456789') = 0 & ax > 0 & ax <= m.ai.0 ,
& symbol('m.ai.ax.zuegelschub') == 'VAR' then
leave
say 'ungueltige Wahl:' ax
end
return nextAuftrag(pre, make, , 'AI.'ax)
endProcedure nextAuftragFromATb
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', m.e.auf7 || m.e.nachtrag
if m.e.qCheck == 0 then nop
else if m.sysRz \== 'RZ1' & m.sysRz \== 'RZ4' then
say 'no quality check from' m.sysRz
else do
qx = m.scopeSrc.rz'/'m.scopeSrc.dbSy
px = m.promPath
qy = word(m.promD.px, words(m.promD.px))
if qualityCheck(qx, qy) then do
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 0
call adrIsp 'vput' vAns 'shared'
ddlxP = substr(m.auftrag.member, 8, 1)
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
call adrIsp "view dataset('"qDsn"'),
macro(ddlX) parm(ddlxP)",4
call adrIsp 'vget' vAns 'shared'
if pos('F', opts) < 1 & \ m.auftrag.force ,
& value(vAns) \== 1 then
return
else
say 'Compare trotz Qualitaetsfehlern'
end
end
m.o.0 = 0
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.dbSy, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast m.e.auf7 || nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast m.e.auf7 || nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
call mapPut e, 'keepTgtV', copies('KEEPTGT,', m.e.keepTgt)
if m.e.tool == ca then
call caDDL o, scopeSrc, translate(mapExp(e, m.e.cChgs))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeSrc.rz'/'m.scopeSrc.dbSy ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat","DDL") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- in the qualityMember say dbx c
to continue processing without option -f ------------------*/
qualityOk: procedure expose m.
parse arg fun
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 1
call adrIsp 'vPut' vAns 'shared'
return 0
endProcedure qualityOk
/*--- find the naming convention for a rz and dbSystem --------------*/
namingConv: procedure expose m.
parse arg rz, dbSy, var
if rz = '.' then do
if pos('.', dbSy) > 0 then
call err 'namingConv old target' dbSy
if pos('/', dbSy) > 0 then
parse var dbSy rz '/' dbSy
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(dbSy)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', m.o.
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh . , a1 a2
call analyseAuftrag
if length(wh) > 2 then do
llq = wh
end
else do /* abbrev: first or first and last character */
ll = ' ANA AN1 AOPT DDL DD1 DD2 EXE' ,
'JCL QUALITY QUICK REC RE1 RDL '
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then
d = '* .JCL' m.e.auftrag
else if llq == 'QUALITY' | (LLQ =='DDL' ,
& a2 =='' & length(a1) <=1) then do
d = '* .'word('DDL QUALITY', pos(wh, 'DQ')) m.e.auf7 ,
|| left(a1 || m.e.nachtrag, 1)
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
if llq == 'DDI' then
llq = 'DDL'
d = r2 d2'.'llq m.e.auf7 || n2
end
parse var d rz dsn mbr
eFun = word('Edit View', 1 + (fun \== 'E'))
if wh = 'Q' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wh == 'A' | wh == 'R' then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"m.libPre || dsn"("mbr")')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"m.libPre || dsn"')",
"member("mbr")" mac, 4
return
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call setIf jOut
call setIf jOut'.TWO'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = a2rzDbSysProm(rzDbSyList)
done = ''
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' dbSy
if opt == '*' then do
nachAll = m.compares
end
else if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if fun = 'IE' & (r == 'RZ2' ,
| (r == 'RZ4' & \ (abbrev(m.e.auftrag, 'Q') ,
|abbrev(m.e.auftrag, '@E') ,
|abbrev(m.e.auftrag, 'WK')))) then
call err 'ie fuer Prod nicht erlaubt:' r'/'dbSy
if m.e.tool = 'CA' then
nachAll = right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
if trgNm = '' then
call err 'compare not found for nachtrag' nachAll
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelN8, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs
else
call mapPut e, 'change',m.e.auftrag':'nachAll'/' ,
|| m.imp.seq'_'zs
call mapPut e, 'change', chaPre'.'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rzDbSys
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', m.e.auf7 || right(nachAll, 1)
done = done rzDbSys
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureDbSy r, dbSy
if m.e.tool == 'CA' then
call caImport jOut, fun, nachAll,
, translate(mapExp(e, m.e.iChgs)),
, translate(mapExp(e, m.e.iMap)),
, translate(mapExp(e, m.e.iRule))
else
call ibmImport jOut, fun, r, dbSy, nachAll,
, translate(mapExp(e, m.e.impMask)),
, translate(mapExp(e, m.e.impIgno))
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fu2)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
call addJobError jOut
call writeSub jOut
sq = ''
if m.e.zuegelN8 \== '' then do
today = translate('78.56.1234', date('s'),'12345678')
do dx=1 to words(done)
d1 = word(done, dx)
if symbol('m.promI.d1') \== 'VAR' then
call warn 'no col for' d1 'in AuftragsTable' m.aTb
else
sq = sq"," word(m.promI.d1, 1) "= '"today"'," ,
word(m.promI.d1, 2) "= '"m.uII"'"
end
end
if sq == '' then do
call warn 'zuegelSchub='m.e.zuegelSchub ,
'kein update in AuftragsTabelle' m.aTb
end
else do
call sqlConnect m.myDbSys
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'"
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'not in table' m.aTb
else if m.sql.1.updateCount \== 1 then do
call sqlUpdate 99, 'rollback'
call err 'auftrag' m.e.auftrag 'got' ,
m.sql.1.updateCount 'updateCount'
end
call sqlCommit
call sqlDisconnect
end
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
toRz = m.myRz
call mapPut e, 'toRz', toRz
if m.o.send.0 \== 0 & m.sysRz \== toRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.toRz.c1 \== 1 then do
m.cdlSent.toRz.c1 = 1
if sAft == '' then do
call mapPut e, 'cdl', dsnSetMbr(c1)
call addIf o
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIf o, 'end'
call setIf o, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
call addIf o
call mAddSt o, o'.TWO'
call addIf o, 'end'
m.o.ifLine = m.o.two.ifLine
end
else do
call addIf o
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call addJobError o'.TWO'
call mAddSt o, o'.TWO'
call mAdd o, la
call addIf o, 'end'
call setIf o, 'SUB'toRz
end
m.o.two.0 = 0
call setIf jOut'.TWO'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o'.SEND', c1
end
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TWO', nachAll
return
endProcedure ibmImport
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
call addIf o
ic = skelStem('Imp')
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIf o, 'end'
call setIf o, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddlIx = 2 - (iChgs \== '')
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib||ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddBB
end
call addIf o'.TWO'
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly == '') ,
copies('keepTgt0', m.e.keepTgt == 0)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AOPT'
call mapPut e, 'stry', nact
call addIf o'.TWO'
call stepGroup
call mapPut e, 'ddlIn', ddlAA
ddlImp = ddlLib'L('nact')'
call mapPut e, 'ddlOut', ddlImp
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'PRE'
call addIf o'.TWO'
call mapPut e, 'ddlin', ddlImp
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AUTO'
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
call stepGroup
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
if m.e.aUtil = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' m.e.aUtil' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
call addIf o'.TWO'
call mapExpAll e, o'.TWO', skelStem('CAna')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'ANA', 0 4, 'POST'
call addIf o'.TWO'
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
oldIf = m.o.two.ifLine
call setIf o'.TWO'
call mapPut e, 'fun', 'execute'
call mapExpAll e, o'.TWO', skelStem(m.jobcard)
call mAdd o'.TWO', '//* Zuegelschub' m.e.zuegelschub k,
, '//* analyse ' date(s) time() m.uNa ,
, '//* nachtrag ' m.e.nachtrag m.e.auf7 || m.e.nachtrag,
, '//* rename old unloads: TSO DBX' m.e.auf7||m.e.nachtrag,
"REN" mapGet(e, 'subsys')
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call mAdd o'.TWO', '}!'
call addIf o'.TWO', 'end'
m.o.two.ifLine = oldIf
call stepGroup old
call setIf o'.TWO', 'EXCP', 0 4
end
if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'EXE', 0 4
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIf o, 'end'
call setIf o, 'DDL', 0 4
call addIf o
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
call addIf o
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
if m.o.ifLine == ''then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o,'// ENDIF' /* for if in skel dbxCRen */
call setIf o, 'RANA', 0 4
return
endProcedure caImpRename
stepGroup: procedure expose m.
parse arg f
old = m.e.stepNo
if f \== '' then
no = f
else
no = old + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return old
endProcedure stepGroup
setIf: procedure expose m.
parse arg o, stp, codes
if stp == '' | m.e.tool = 'IBM' then
li = ''
else do
li = ''
do ax=2 by 2 to arg()
stp = arg(ax)
codes = arg(ax+1)
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = li 'AND' stp'.RUN AND'
if codes == '' then
li = li stp'.RC=0'
else if words(codes) = 1 then
li = li stp'.RC='strip(codes)
else do
li = li '('stp'.RC='word(codes, 1)
do cx=2 to words(codes)
li = li 'OR' stp'.RC='word(codes,cx)
end
li = li')'
end
end
li = substr(li, 6)
end
m.o.ifLine = li
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt, cond
if m.o.ifLine == '' & opt \== 1 then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else do
pr = '// IF'
if cond == '' then
cond = m.o.ifLine
cond = space(cond, 1)
do while length(cond) > 53
ex = lastPos(' ', left(cond, 53))
call mAdd o, pr left(cond, ex-1)
cond = substr(cond, ex+1)
pr = left('//', length(pr))
end
call mAdd o, pr cond 'THEN'
end
return
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if cond = '' then
cond = 'RC=0'
call addIf o, 1, 'ABEND OR RC > 4 OR NOT (' cond ')'
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.ddlOnly = 0
m.e.zuegelschub = ''
m.e.aOpt = ''
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER ICHGS IMPMASK IMAP IRULE IMPIGNO'
varWu = 'CCHGS COMMASK COMIGNO' ,
'AOPT AMODEL AUTIL VP0 VP1 VP2 VP3 VP4 VPT VP16 VP17' ,
'KEEPTGT DBACHECK QCHECK CA BMC IBM DDLONLY'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.auf7 = left(w2, 7)
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
if m.e.ddlOnly == '' | m.e.ddlOnly == 1 then
m.e.ddlOnly = ''
else
m.e.ddlOnly = 'UNLOAD'
if m.e.cChgs == '' then
m.e.cChgs = 'PROT'm.e.prodDbSys
if m.e.iChgs == '' then
m.e.iChgs = dsnGetMbr(m.e.impMask)
else if m.e.impMask == '' then
m.e.impMask = m.libPre'.MASK('m.e.iChgs')'
if m.e.iRule == '' then
m.e.iRule = dsnGetMbr(m.e.impIgno)
else if m.e.impIgno == '' then
m.e.impIgno = m.libPre'.MASK('m.e.iRule')'
call mapPut e, 'aModel', m.e.aModel
zt = translate(m.e.zuegelschub, '000000000', '123456789')
if zt == '00.00.0000' then do
m.e.zuegelN8 = translate('67893401', m.e.zuegelSchub,
,'0123456789')
end
else if zt == '00000000' then do
m.e.zuegelN8 = m.e.zuegelSchub
m.e.zuegelschub = translate('78.56.1234', m.e.zuegelN8,
,'12345678')
end
else do
m.e.zuegelN8 = ''
end
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.dbSy, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop dbSy
say ' scope ' m.scp.0 m.scp.dbSy ,
' target ' m.scopeTrg.0 m.scopeTrg.dbSy
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
sayImp: procedure expose m.
do ix=1 to m.imp.0
say 'imp' m.imp.ix.nachtrag 'to' m.imp.ix.rz'/'m.imp.ix.dbSys
end
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureDbSy m.scopeTrg.rz, m.scopeTrg.dbSy
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- create jcl to copy one member to rz toRz and library toLib -----*/
copyMbr: procedure expose m.
parse arg o, mbr, frLib, toRz, toLib
call mapPut e, 'mbr', mbr
call mapPut e, 'frLib', dsnSetMbr(frLib)
call mapPut e, 'toRz', toRz
call mapPut e, 'toLib', dsnSetMbr(toLib)
call addIf o
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIf o, 'end'
call setIf o, 'COPY', 0
return
endProcedure copyMbr
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlConnect m.scp.dbSy
else
call sqlConnect m.scp.rz'/'m.scp.dbSy
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
trace ?r
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
removeQualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure removeQualityCheck
/*--- Qualitaets Pruefung mittels ddlCheck ---------------------------*/
qualityCheck: procedure expose m.
parse arg x, y
m.spezialFall.done = ''
lst = ''
scp = 'SCOPESRC'
o = 'AUFTRAG'
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then
f1 = 'db:'m.sn.name
else if m.sn.Type = 'TS' then
f1 = 'ts:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'TB' then
f1 = 't:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'VW' then
f1 = 'v:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'IX' then
f1 = 'i:'m.sn.qual'.'m.sn.name
else
iterate
f1 = space(f1, 0)
if wordPos(f1, lst) > 0 then
iterate
lst = lst f1
end
m.o.orig = 'rmQu' m.o.orig
if lst = '' then do
say 'qualitycheck no objects to check'
call mAdd o, '|| qualitycheck no objects to check'
return 0
end
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
cRes = ddlCheck('CHECK' qDsn x y lst)
call splitNl cr, cRes
cr1 = substr(m.cr.1, 4)','
if pos('\n', cRes) > 0 then
cr1 = left(cRes, pos('\n', cRes)-1)','
else
cr1 = cRes','
res = pos('q,', cr1) > 0 | pos('*sb,', cr1) > 0 ,
| pos('*p', cr1) > 0 | pos('*n,', cr1) > 0 ,
| pos('special', cr1) > 0 | pos('*-,', cr1) > 0
if \ res then do /* add new | lines to auftrag */
call mAdd o, '|| qualitycheck ok:' substr(m.cr.1, 4)
end
else do
call mAdd o, '|| qualitycheck:' substr(m.cr.1, 4)
call mAddSt o, cr, 2
end
return res
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
removeSspezialFall: procedure expose m. --> ddlCheck
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-' left(m.st.sx, 78)
end
return
endProcedure removeSpezialFall
/*--- mask handling initialise ---------------------------------------*/
removemaskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
removemaskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
removetestMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
removeMaskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
removemask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
removemaskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
removemaskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
removemaskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg dbSy
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & dbSy == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if dbSy = '' then
dbSy = if(subs2 == '', m.pr1Sub, subs2)
dbSy = translate(dbSy, '/', '.')
if abbrev(dbSy, m.sysRz'/') then
dbSy = substr(dbSy, 5)
call sqlConnect dbSy
dbSy = translate(dbSy, m.ut.alfLC, m.ut.alfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu dbSy) < 70 then
neu = left(neu, 68 - length(dbSy)) '*'dbSy
else if length(neu dbSy) < 80 then
neu = neu '*'dbSy
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(name)," ,
"case when nTables <> 1",
"then 'ty=' || type" ,
"|| ', ' || nTables || ' tables||| '",
"else value( (select 'tb '" ,
"|| strip(t.creator) ||'.'|| strip(t.name)",
"|| case when t.type = 'T' then ''" ,
"else ' ty=' || t.type end" ,
"from sysibm.systables t" ,
"where t.type not in ('A','V')" ,
"and t.dbName=s.dbName and t.tsName=s.name" ,
"), 'not found')" ,
"end" ,
"from sysibm.systableSpace s" ,
"where dbName" sqlClause(qu) "and name" sqlClause(nm)
/*???else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end" ,
"|| min(strip(creator) ||'.'|| strip(name))",
"|| case when count(*) = 1 and min(type) <> 'T'" ,
"then ' ty=' || min(type) else '' end" ,
"from sysibm.systables" ,
"where type not in ('A','V')" ,
"and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName" ???????????*/
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case type when 'V' then 'vw'",
"when 'A' then 'al' else 'tb' end," ,
"strip(creator) || '.' || strip(name)" ,
"|| case when type <> '"left(ty, 1)"'" ,
"then ' ty=' || type else '' end," ,
"case when type = 'A' then 'for '" ,
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type" if(ty=='TB', "not in ('A', 'V')" ,
, "= '"left(ty, 1)"'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IS' then
sql = "select 'is', strip(dbName) ||'.'|| strip(indexSpace),",
"'tb ' || strip(tbCreator)|| '.' || strip(tbName)" ,
" || ' ix ' || strip(name)" ,
'from sysibm.sysIndexes' ,
'where dbname' sqlClause(qu),
'and indexSpace' sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = m.e.auf7 || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' oDsn)
call caDD1 o, scp, GlbChg, oDsn
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg, ddlOut
call mapPut e, 'user', userid()
call mapPut e, 'ddlOut', ddlOut
call mapExpAll e, o, skelStem('CCOM')
call mapPut e, 'comm', mapExp(e, 'dbx $fun',
copies('recover', pos('.RDL(', ddlOut) > 0)'DDL' ,
'$AUFTRAG $NACHTRAG')
if abbrev(scp, '//') then
call mAdd o, scp, '// DD *'
else do sx=1 to m.scp.0
call rcmQuickAdd o, m.scp.sx.type, m.scp.sx.qual, m.scp.sx.name
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".GlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V SQ' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V SQ' , 'EXPLODE ROUTINE'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
call rcmQuickTyp1 'SEQUENCE ', 'SQ Q'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.dbSy \== m.scopeTrg.dbSy then
call err 'bmc compare on different dbSystems not implemented'
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlConnect m.scp.dbSy
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
zglSchub: procedure expose m.
parse arg fun rest
if length(fun) = 4 & datatype(fun, 'n') then
parse arg zgl fun rest
else
zgl = substr(date('s'), 3, 4)
only18 = fun == 18
if only18 then
parse var rest fun rest
if fun = '' then
call err 'zglSchub kein Fun fuer Auftraege:' arg(1)
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
copies("and einfuehrungs_zeit = '18:00'", only18) , zsa
call sqlDisconnect
do zx=1 to m.zsa.0
if m.zsa.zx.workliste = '' then
iterate
say zx m.zsa.zx.workliste m.zsa.zx.auftrag ,
m.zsa.zx.einfuehrungs_zeit m.zsa.zx.id7
call work m.zsa.zx.workliste fun rest
end
endProcedure zglSchub
/*--- zStat Zuegelschub Statistik ------------------------------------*/
zstat a? yymm? - in rz4, create AyyMM mit AuftragsListe
----------------------------------------------------------------------*/
zStat: procedure expose m.
parse upper arg aArg
parse upper arg fun zgl
rz = sysvar('sysNode')
if fun = '' then
if rz = 'RZ4' then
fun = 'A'
else if rz = 'RZ2' | rz = 'RR2' | rz = 'RQ2' then
fun = 'S'
z0 = translate(zgl, '000000000', '123456789')
if zgl = '' then
z1 = substr(date('s'), 3, 4)
else if z0 == '0000' then
z1 = zgl
else if z0 == '000000' then
z1 = substr(zgl, 3)
else if z0 == '00.00.00' then
z1 = translate('5634', zgl, '12.34.56')
else
call err 'bad Zugelschub should be yymm or dd.nn.yy not' zgl
aDsn = m.libPre'.ZGL(ZSTA'z1')'
sDsn = m.libpre'.ZGL(ZSTS'z1')'
if fun = 'A' then do
if rz <> 'RZ4' then
call err 'zstat a... only in rz4'
if sysDsn("'"aDsn"'") == 'OK' then
call err "e}"aDsn "existiert schon"
call zStatAuftragsListe z1, m.libPre'.auftrag', aDsn
end
else if fun == 'S' then do
if rz <> 'RZ2' & rz <> 'RR2' & rz <> 'RQ2' & rz <> 'RZ4' then
call err 'zstat s... only in rz2 or rz4'
if sysDsn("'"aDsn"'") \== 'OK' then
call err aDsn "existiert nicht"
call zStatsStatistik z1, aDsn, sDsn
end
else
call err 'i}bad fun' fun 'in arguments zStat' aArg
return 0
endProcedure zStat
zStatAuftragsListe: procedure expose m.
parse arg zgl, lib, outDsn
zg2 = '20'zgl
zg3 = translate('.34.12', zgl, '1234')
zg4 = translate('.cd.20ab', zgl, 'abcd')
call sqlConnect m.myDbSys
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy rTy ., t aa
m.rcm_quickT2DB2.t = dTy
if rTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = rTy
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
mv = 'UNITCNT(30)' /* 3.10.13 wieder zurueck */
say 'creating' dsn 'with multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call tsoFree word(alRes, 2)
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'",
c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if disp = 'NEW' & nn \== '' then
a2 = a2 dsnCreateAtts( , nn, 1)
if retRc <> '' | nn = '' then
return adrCsm('allocate' al a2 rest, retRc)
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return 0
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX'
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 77
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/* copy csm end *******************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort.comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort.comparator = "aLe =" le "; aRi =" ri";" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
call jIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlOIni
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
hst = ''
cTy = 'Rx'
end
if m.sql.conType==cTy & m.sqlHost==hst & m.sqlconDbSYs == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
else
m.sql.conDbSys = sys
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conDbSys = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, resTy
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if (sub == '' & m.sql.conDbSys== '') ,
| (sub \== '' & m.sql.conDbSys \== sub) then
call sqlConnect sub
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call scanSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql.sqlHaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then
return sqlMsgLine( , upds, src, coms 'commits')
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ut2Lc(fun)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut.alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%qn %S'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlReset crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec 'describe cursor c'crs 'into :m.sql.'crs'.D'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%qn v, f %s')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = oNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conDbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, resTy, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
f = ''
if resTy \== '' then do
f = oClaMet(class4Name(resTy), 'oFlds')
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk, resTy
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
if resTy \== '' then
m.sql.cx.type = class4Name(resTy)
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- return csv header line -----------------------------------------*/
sqlHeaderCSV: procedure expose m.
parse arg cx
x = sqlRxFetchVars(cx)
return mCatFT('SQL.'cx'.COL', 1, m.sql.cx.d.sqlD, '%qn,%s')
endProcedure sqlHeaderCSV
/*--- fetch next row return it as csv line, return '' at end ---------*/
sqlFetchCSV: procedure expose m.
parse arg cx, retOk
dst = 'sql.csvFetch'
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return ''
if fetCode < 0 then
return fetCode
res = ''
do kx=1 to m.sql.cx.d.sqlD
cn = m.sql.cx.col.kx
val = m.dst.cn
if m.sql.cx.d.kx.sqlType // 2 = 1 & m.dst.col.sqlInd < 0 then
res = res','m.sqlNull
else if pos(',', val) > 0 | pos('"', val) > 0 then
res = res','quote(val, '"')
else
res = res','val
end
return substr(res, 2)
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlRxClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlRxClose cx
return res
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = oClaMet(f, 'oFlds')
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlRxFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000, sqlErrd.5)
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut.alfRexN1) > 0 then
iterate
ex = verify(src, m.ut.alfRex, 'n', cx)
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
else
fmt = '%s%qn %s%qe%q^'fmt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%Qn', m.line)
end
call jClose m
return res || f(fmt'%Qe')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
sta = 'tt'
res = ''
do forever
do while scanSBEnd(m)
if \ jCatSqlNl(m) then
return strip(res)
end
bx = m.m.pos
sta = scanSql2Stop(m, sta, stop)
s1 = left(sta, 1)
if pos(s1, stop) > 0 then do
if res <> '' then
return strip(res)
end
else if s1 == '-' | s1 == '/' then
res = res' '
else if pos('/', sta) = 0 then
res = res || substr(m.m.src, bx, m.m.pos - bx)
end
/*-------- ?????????????????????
jCatSqlNext?: procedure expose m.
parse arg m, stop
res = ''
bx = m.m.pos
do forever
call scanUntil m, '"''-/'stop
if scanSBEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if scanLit(m, "'", '"') then do
c1 = m.m.tok
do while \ scanStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call scanChar m, 1
if res <> '' then
return strip(res)
bx = m.m.pos
end
else if \ scanLit(m, '-', '/') then do
call err 'bad char at' substr(m.m.src, m.m.pos) 'in' m.m.src
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return strip(res)
end
endProcedure jCatSqlNext
??????????????*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new return jReset("m.class.basicNew", arg, arg2, arg3)",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new return jReset("m.class.basicNew", arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if oClaInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: 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
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: 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
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
if the parent is class OLazyMet, a methof found there is
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o.ini == 1 then
return
m.o.ini = 1
call mIni
m.o.escW = '!'
m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
call oAddCla m.o.lazyGen
return
endProcedure oIni
/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla
/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
call err 'bad class name' cl 'in oAddCla('cl',' parents')'
if oIsCla(cl) then
call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
do px=1 to words(parents)
if \ oIsCla(word(parents, px)) then
call err word(parents, px) 'is no class' ,
'in oAddCla('cl',' parents')'
end
m.o.cParent.cl = parents
return
endProcedure oAddCla
/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
if \ oIsCla(cl) then
call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
if symbol('m.o.cMet.cl.met') == 'VAR' then
call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
m.o.cMet.cl.met = cont
return
endProcedure oAddMet
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
interpret oClaMet(cl, 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o.escW) then
return m.class.classW
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return oClaInheritsOf(cl, sup)
endProcedure oKindOf
oClaInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
if symbol('m.o.cParent.sup') \== 'VAR' then
sup = class4name(sup)
if cl == sup then
return 1
do sx=1 to words(m.o.cParent.cl)
if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
return 1
end
return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o.escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.o.cMet.ggClass.me') == 'VAR' then
return m.o.cMet.ggClass.me
code = oClaMet(ggClass, me, '---')
if code \== '---' then
return code
else if arg() >= 3 then
return arg(3)
return err('no method' me 'in class' className(ggClass) ,
'of object' m)
endProcedure objMet
oClaMet: procedure expose m.
parse arg cl, me
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
if \ oIsCla(cl) then do
c2 = class4Name(cl, '')
if c2 \== '' & oIsCla(c2) then do
cl = c2
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
end
else do
if arg() >= 3 then
return arg(3)
else
return err('no class' cl 'in oClaMet('cl',' me')')
end
end
code = oLazyMetGen(m.o.lazyGen, cl, me)
do px = 1 to words(m.o.cParent.cl) while code == '---'
code = oClaMet(word(m.o.cParent.cl, px), me, '---')
end
if code == '---' then do
if arg() >= 3 then
return arg(3)
else
return err('no met' me 'in class' cl)
end
m.o.cMet.cl.me = code
return code
endProcedure oClaMet
oLazyMetGen: procedure expose m.
parse arg lg, cl, me
if symbol('m.o.cMet.lg.me') \== 'VAR' then
return '---'
interpret m.o.cMet.lg.me
endProcedure oLazyMetGen
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.o.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProcedure oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
oClaClear: procedure expose m.
parse arg cla, m
interpret "drop cla;" oClaMet(cla, 'oClear')
return m
endProcedure oClaClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
call oClaMet cl, 'oFlds'
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = oNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" oClaMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.class.in2 = 0
call oIni
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
m.class.basicNew = "oMutate(mNew(cl), cl)"
call oAddMet m.o.lazyGen, 'new', "return classGenNew(cl, me)"
call oAddMet m.o.lazyGen,'oClear',"return classGenClear(cl, me)"
call oAddMet m.o.lazyGen,'oFlds',"return classGenFlds(cl, me)"
call oAddMet m.o.lazyGen, 'oCopy', "return classGenCopy(cl, me)"
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classFinish cr
call oClaMet cr, 'oFlds' /* generate flds */
end
m.class.in2 = 1
call oAddMet m.class.classV, 'oCopy', "return oCopyV(m, t)"
call classAddMet m.class.classV, 'o2String return m.m'
call classAddMet m.class.classW, 'o2String return substr(m, 2)'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if isNew & m.class.in2 then
call classFinish n
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
return n
endProcedure classNew
/*--- to the finish for new class cl -------------------------------*/
classFinish: procedure expose m.
parse arg cl, force
call oMutate cl, m.class.class
/* find super and sub classes */
m.cl.sub = ''
sups = ''
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 \== 'u' then
iterate
if wordPos(u1, sups) > 0 then
call err u1 'already in sups' sups': classSuperSub('cl')'
sups = sups u1
if wordPos(m.cl.SUB, cl) > 0 | symbol('m.u1.sub') \== 'VAR' then
call err cl 'is already in' u1'.sub' u1.SUB ,
|| ': classSuperSub('cl')'
m.u1.sub = strip(m.u1.sub cl)
end
m.cl.super = sups
/* add class to o */
call oAddCla cl, sups
if pos(m.cl, 'mfrsv') < 1 then do
allMets = ''
forceMets = ''
do cx=1 to m.cl.0
ch = m.cl.cx
if m.ch == 'm' then do
call oAddMet cl, m.ch.name, m.ch.met
allMets = allMets m.ch.name
end
else if symbol('m.class.forceDown.ch') == 'VAR' then
forceMets = forceMets m.class.forceDown.ch
end
myForce = ''
do fx=1 to words(forceMets)
parse value word(forceMets, fx) with fCla '#' fMet
if wordPos(fMet, allMets) < 1 then do
call oAddMet cl, fMet, m.o.cMet.fCla.fMet
myForce = myForce cl'#'fMet
allMets = allMets fMet
end
end
if myForce \== '' then
m.class.forceDown.cl = strip(myForce)
end
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object addresses */
call mNewArea cl, 'O.'substr(cl,7)
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
return
endProcedure classFinish
classAddMet: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
call mAdd cl, classNew('m' met code)
call oAddMet cl, met, code
return cl
endProcedure classAddMet
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
classGenNew: procedure expose m.
parse arg cl, met
return "m=" m.class.basicNew";" oClaMet(cl, 'oClear') ";" ,
"return m"
endProcedure classGenNew
classGenFlds: procedure expose m.
parse arg cl, met
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classGenFldsAdd cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
return cl'.FLDS'
endProcedure classGenFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classGenFldsAdd: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classGenFldsAdd(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classGenFldsAdd(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classGenFldsAdd f, m.cl.tx, nm
end
return 0
endProcedure classGenFldsAdd
classGenClear: procedure expose m.
parse arg cl, met
r = ''
call oClaMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
r = r classGenStmt(f1, "m.m~ = '"m.o.escW"';")
else
r = r classGenStmt(f1, "m.m~ = '';")
end
do sx=1 to m.cl.stms.0
r = r classGenStmt(m.cl.stms.sx, "m.m~.0 = 0;")
end
return r
endProcedure classGenClear
classGenStmt: procedure expose m.
parse arg f, st, resWo
isNice = translate(f) == f
resWo = translate(resWo) 'GGFF M'
fDod = '.'f'.'
do wx=1 to words(resWo) while isNice
isNice = pos('.'word(resWo, wx)'.', fDot) < 1
end
if isNice then
return repAll(st, '~', f)
else
return "ggFF = '"substr(f, 2)"';" repAll(st, '~', '.ggFF')
endProceduer classGenAss
classGenCopy: procedure expose m.
parse arg cl, me
r = repAll("if t == '' then t =" m.class.basicNew ";" ,
"else call oMutate t, cl;", 'cl', "'"cl"'")
ff = oClaMet(cl, 'oFlds') /* build code for copy */
do fx=1 to m.cl.flds.0
r = r classGenStmt(m.cl.flds.fx, 'm.t~ = m.m~;', 't')
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == '' then
st = ''
else do
r = r "st = '"substr(nm, 2)"';"
st = '.st'
end
r = r "m.t"st".0 = m.m"st".0;" ,
"do sx=1 to m.m"st".0;" ,
"call oClaCopy '"sc"', m"st".sx, t"st".sx; end;"
end
return r 'return t;'
endProcedure classGenCopy
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class.classV)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut.alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '%s%qn%s%qe%q^'fmt
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCatFT
mIni: procedure expose m.
if m.m.ini == 1 then
return
m.m.ini = 1
call utIni
m.mBase64 = m.ut.alfUC || m.ut.alfLc || m.ut.digits'+-'
m.m.area.0 = 0
call mNewArea
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 tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' readNxLiNo(m)li
endProcedure readnxPos
readNxLiNo: procedure expose m.
parse arg m
return m.m.buf0x + m.m.cx
endProcedure readnxLiNo
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'o' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'a' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(10, 1000) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
m.ut.alfId = m.ut.alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut.alfIdN1 = m.ut.digits /* not as first character */
m.ut.alfRex = m.ut.Alfa'.0123456789@#$?' /* charset puff mit ¬*/
m.ut.alfRexN1= '.0123456789'
m.ut.alfPrint = m.ut.alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.alfIdN1) > 0 then
return 1
else
return verify(src, m.ut.alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBXREN) cre=2013-01-08 mod=2013-01-08-12.42.57 A540769 ---
parse arg dbsy ana
if dbSy == '' then
parse value 'DBAF WK40300F' with dbsy ana
say 'dbsy' dbsy 'ana' ana
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
say dx m.csi.dx
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
say dx m.csi.dx
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
say 'y' ly 'l' last 'dsn' m.csi.cx
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
exit
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBXR2) cre=2016-03-15 mod=2016-03-15-08.16.35 A540769 ----
$#@
call iiIni
rz = sysvar(sysnode)
say m.ii_rz2db.rz
do dx=1 to words(m.ii_rz2db.rz)
dbSys = word(m.ii_rz2db.rz, dx)
call adrTso rename "'dsn.dbx"dbSys".DDL'" "'dsn.dbx"dbSys".DDI'"
end
}¢--- A540769.WK.REXX(DBXSRCH) cre=2012-08-23 mod=2012-08-24-11.04.46 A540769 ---
$<#¢
AC04002W
AX01001W
BV01002W
CD01004C
CD02014W
CD03020W
CD03021C
CZMIX02W
DGMIX01C
DG01049W
DG01050C
DG02008W
DG02009W
DI01001W
DI05009W
DP08012C
DW10004C
ER01033W
ER01034C
EU04002W
EU99001W
FI04052C
FI04053W
GM01008C
KB01004C
KC01009W
MARTIN0W
MARTIN1C
MARTIN2C
MF03003W
MI01019C
NITRIG1C
NI02174C
NI02175C
NI03003W
NI04003C
NI10034C
NI10035W
NI10036C
OS03005C
OZ01009C
PC01032C
RA01001W
RENI001D
RV01009W
SU10001W
SV10016C
TG01012C
TT01002W
TT01003C
TV01001W
UU02011C
VV21005W
VV24001C
WA01038C
WB20003C
WF01024C
WI02033C
WI02034W
WI02035C
WK09901C
WK99101C
WK99501C
WU10010W
WU36001W
WU40018C
WU40019C
WU91001W
WY40001C
XB03051W
XB03052C
XR01023W
XR01024C
YN01003W
$!
$@for w $@¢
w = strip(left($w, 7))
call lmm 'dsn.dbx.cdl('w'*)'
$!
$| $@¢
qq=''
$@for w $@¢
qq = qq','strip($w)
if length(qq) > 50 then $@¢
$$- 'SELECT' substr(qq, 2)
qq=''
$!
$!
$$- 'SELECT' substr(qq, 2)
$!
$#out 20120824 11:04:22
SELECT AC040020,AX010010,BV010020,CD010040,CD010041,CD020140
SELECT CD020141,CD020142,CD030200,CD030210,CZMIX020,DGMIX010
SELECT DG010490,DG010500,DG020080,DG020090,DI010010,DI050090
SELECT DP080120,DP080121,DP080122,DW100040,ER010330,ER010340
SELECT ER010341,EU040020,EU040021,EU990010,FI040520,FI040530
SELECT GM010080,KB010040,KC010090,KC010091,MARTIN00,MARTIN01
SELECT MARTIN10,MARTIN20,MF030030,MF030031,MF030032,MI010190
SELECT MI010191,MI010192,MI010193,NITRIG10,NI021740,NI021741
SELECT NI021750,NI021751,NI030030,NI030031,NI040030,NI040031
SELECT NI100340,NI100341,NI100342,NI100343,NI100344,NI100345
SELECT NI100346,NI100347,NI100348,NI100350,NI100351,NI100352
SELECT NI100353,NI100354,NI100360,OS030050,OZ010090,PC010320
SELECT RA01001A,RA01001B,RA01001C,RA010010,RA010011,RA010012
SELECT RA010013,RA010014,RA010015,RA010016,RA010017,RA010018
SELECT RA010019,RENI0010,RENI0011,RV010090,SU100010,SV100160
SELECT SV100161,TG010120,TG010121,TT010020,TT010021,TT010030
SELECT TT010031,TV010010,TV010011,UU020110,VV210050,VV240010
SELECT WA010380,WA010381,WB200030,WF010240,WI020330,WI020340
SELECT WI020350,WK099010,WK099011,WK099012,WK991012,WK991013
SELECT WK995010,WU100100,WU100101,WU100102,WU360010,WU360011
SELECT WU400180,WU400181,WU400182,WU400183,WU400190,WU400191
SELECT WU910010,WY400010,XB030510,XB030520,XR010230,XR010240
SELECT YN010030,YN010031,YN010032
$#out 20120823 15:40:05
SELECT AC040020,AX010010,BV010020,CD010040,CD020140,CD020141
SELECT CD020142,CD030200,CD030210,DGMIX010,DG010490,DG010500
SELECT DG020080,DG020090,DI010010,DI050090,DP080120,DP080121
SELECT DP080122,DW100040,ER010330,ER010340,ER010341,EU040020
SELECT EU040021,EU990010,FI040520,FI040530,GM010080,KC010090
SELECT KC010091,MARTIN00,MARTIN01,MARTIN10,MARTIN20,MF030030
SELECT MF030031,MF030032,NITRIG10,NI021740,NI021741,NI021750
SELECT NI030030,NI030031,NI040030,NI040031,NI100340,NI100341
SELECT NI100342,NI100343,NI100344,NI100345,NI100346,NI100347
SELECT NI100348,NI100350,NI100351,NI100352,NI100353,NI100354
SELECT NI100360,OS030050,OZ010090,PC010320,RENI0010,RENI0011
SELECT SU100010,SV100160,SV100161,TG010120,TG010121,TT010020
SELECT TT010021,TT010030,TT010031,TV010010,TV010011,UU020110
SELECT VV210050,VV240010,WA010380,WA010381,WB200030,WF010240
SELECT WI020330,WI020340,WI020350,WK099010,WK099011,WK099012
SELECT WK991012,WK991013,WK995010,WU100100,WU100101,WU100102
SELECT WU360010,WU360011,WU400180,WU400181,WU400182,WU400190
SELECT WU400191,WU910010,WY400010,XB030510,XB030520,XR010230
SELECT XR010240,YN010030,YN010031,YN010032
$#out 20120823 15:39:36
*** compile error ***
scanErr ending $! expected after ¢
last token scanPosition
atEnd after line 85: $$- 'SELECT' substr(qq, 2)
$#out 20120823 15:35:33
}¢--- A540769.WK.REXX(DBXWSH) cre=2009-10-05 mod=2009-10-05-16.01.14 A540769 ---
$=auft=DSN.DBX.AUFTRAG
$=auCo=DSN.DBA.ZUEGEL.AUFTRAG.DIRPRO
$=auCo=A540769.TMP.AUFTCOPY
$;
$<=/wsls/
WK90001C 01
$*( WK90002C 0
WK90003C 0
WK90001C 01
WK90002C 0
WK90001C 01
WK90002C 0
WK90003C 0
WK90001C 01
WK90002C 0
$*) WK90003C 0
$/wsls/
$@for ii $@/doOne/
parse value $ii with mbr opt
c = '-a'mbr 'i rr2.DBoF' strip(opt)
result = 'fail'
res = adrTso('%DBX' c, '*')
say 'res' res 'for dbx' c
trace ?r
call readDsn $auft'('mbr')', 'I.'
call writeDsn $auCo'('mbr') ::f', 'I.', , 1
$/doOne/
$***out 20091005 15:49:00
$***out 20091005 15:43:34
$***out 20091005 15:41:51
$***out 20091005 15:40:43
$***out 20091005 15:40:26
$***out 20091005 15:40:03
$***out 20091005 15:38:07
$***out 20091005 15:23:10
$***out 20091005 15:22:56
$***out 20091005 15:22:39
$***out 20091005 14:43:13
$***out 20091005 14:42:09
$***out 20091005 14:41:34
$***out 20091005 14:40:07
$***out 20091005 14:38:05
$***out 20091005 14:37:31
$***out 20091005 14:36:09
$***out 20091005 14:33:33
$***out 20091005 14:30:05
-aWK90001C i DBZF
-aWK90002C i DBZF 23
-aWK90003C i DBZF
$***out
}¢--- A540769.WK.REXX(DBX0823) cre=2012-11-26 mod=2012-11-26-16.21.23 A540769 ---
/* rexx ****************************************************************
synopsis: DBX fun args v1.4
edit macro fuer CS Nutzung von DB2 AdminTool 10.1
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
a,aw,ac pr naechste AuftragsId suchen fuer praefix pr
a: anzueigen, aw, ac entsprechendes Member editieren
n, nt neuen Auftrag erstellen (nt = test)
q subSys? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* ergaenzt scope Zeile mit infos, z.B tb -> ts
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren,
sonst werden alle expandiert
* funktioniert nicht nur in Auftrag
falls SubSys angegeben wird da gesucht sonst DBAF/DBOF
c opt? compare source gegen target
i subs nct changes in Db2Subsystem subSys importieren
subs = sub(,sub)*: Liste von Subsystemen/Umgebungen
sub: DBAF (lokal), RR2/DBOF (im PTA), RZ8(betr. Subsys)
ET, IT, PA (pta), PR (prod), pq(pta+rq2)
==> Rz/Subsys des PromotionPaths
nct: Nachtraege:
leer: noch nicht in dieses SubSys importierte
= : vom letzten import plus neue
89A : Nachtraege 8, 9 und A
v opt? version files erstellen für altes Verfahren
vc vj vs vt ec ej es et nt? : view or edit cdl,jcl,srcDdl,trgDdl
sw rz? WSL ins RZ rz schicken und clonen, ohne rz multiclone
do cmd for auftraege: batchfunktion cmd fuer jeden auftrag
opt? Optionale Optionen =, -f, -=f etc. (fuer c, v, st)
= statt aktuelle source aus Db2 extrahieren
letzte extrahierte Version als Source brauchen
-f force: ignoriere QualitaetsVerletzungen
cloneWsl dbaMulti Funktionalitaet ist hier implementiert
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: v10, v72, keeptgt 0, qCheck 0, dbaCheck 0
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
Optionen: ca, bmc, ibm
Funktionen: ia (imp+ana), ie (ia+exe), ee,ve (exejcl), ew,vw (wsl)
************************************************************************
23. 8.2012 W. Keller v1015 für extract
*/ /* end of help
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset h
if sysvar(sysispf) = 'ACTIVE' then
call adrIsp 'Control errors return'
call jIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
m.auftrag.force = 0
do while abbrev(fun, '-')
r = substr(fun, 3)
if abbrev(fun, '-A') then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then do
m.auftrag.force = 1
end
else do
call err 'bad opt' fun 'in' wArgs
end
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
end
if 0 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
call mapPut e, 'rexxLib', 'ORG.U0009.B0106.KIDI63.EXEC'
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if wordPos(fun, 'A AC AW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if fun = 'COPYDUMMY' then
return copyDummy(args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
call memberOpt
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if wordPos(fun, 'VC VE VJ VS VT VW EC EE EJ ES ET EW') > 0 then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
m.uNa = 'Marc'
else if m.uId = 'A390880' then
m.uNa = 'Martin'
else if m.uId = 'A540769' then
m.uNa = 'Walter'
else if m.uId = 'A666308' then
m.uNa = 'Frank'
else if m.uId = 'A754048' then
m.uNa = 'Alessandro'
else if m.uId = 'A790472' then
m.uNa = 'Agnes'
else if m.uId = 'A828386' then
m.uNa = 'Reni'
else if m.uId = 'A914227' then
m.uNa = 'Gerrit'
else
m.uNa = m.uId
m.scopeTypes = 'DB TS TB VW AL IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths */
m.iProm.1 = 'ET IT PQ PA PR'
m.iProm.2 = 'RZ1/DBAF,RZ8/DC0G RZ1/DBTF,RZ8/DD0G,RZZ/DE0G' ,
'RQ2/DBOF,RR2/DBOF RR2/DBOF RZ2/DBOF'
m.iProm.3 = 'RZ1/DBBA,RZ8/DCVG RZ1/DVTB,RZ8/DDVG,RZZ/DEVG' ,
'RQ2/DVBP,RR2/DVBP RR2/DVBP RZ2/DVBP'
m.iProm.0 = 3
return
endProcedure dbxIni
/*--- expand the import target list entered by the user
to a list or rz/subsys, with mySub first and the rest sorted*/
iListExpand: procedure expose m.
parse upper arg srcList
tl = iPromExpand(translate(space(srcList, 0), '/ ', '.,'))
local = ''
remote = ''
do tx=1 to words(tl)
t1 = word(tl, tx)
if abbrev(t1, m.myRz'/') then
local = wordInsAsc(local, t1)
else
remote = wordInsAsc(remote, t1)
end
return local remote
endProcedure iListExpand
/*--- expand a target using iProm infos to a list of rz/subsys -------*/
iPromExpand: procedure expose m.
parse arg inp
if words(inp) <> 1 then do /* several words, expand each */
out = ''
do wx=1 to words(inp)
out = out iPromExpand(word(inp, wx))
end
return out
end
if pos('/', inp) > 0 then /* already expanded */
return inp
if inp == '?*?' then do /* find current promotionPath */
tg = m.scopeTrg.rz'/'m.scopeTrg.subSys
do tx=2 to m.iProm.0
if pos(tg, m.iProm.tx) > 0 then
return m.iprom.tx
end
call err 'target' tg 'not in any PromotionPath'
end
px = wordPos(inp, m.iProm.1) /* one promotion environment */
if px > 0 then
return translate(word(iPromExpand('?*?'), px), ' ', ',')
if length(inp) = 4 then /* prepend rz to subsys */
return m.myRz'/'inp
/* all subsys that match something */
alOr = iPromExpand('?*?')
all = translate(alOr, ' ', ',')
out = ''
do ax = 1 to words(all)
if pos(inp, word(all, ax)) > 0 then
if wordPos(word(all, ax), out) < 1 then
out = out word(all, ax)
end
if out \== '' then
return out
call err 'inp' inp ' not found in promotionPath' alOr
endProcedure iPromExpand
wordInsAsc: procedure expose m.
parse arg lst, wrds
do wx=1
w = word(wrds, wx)
if w == '' then
return space(lst, 1)
do rx=1 to words(lst) while w > word(lst, rx)
end
r1 = word(lst, rx)
if r1 == '' then
lst = lst w
else if w < r1 then
lst = subWord(lst, 1, rx-1) w subWord(lst, rx)
end
endProcedure wordInsAsc
charInsAsc: procedure expose m.
parse arg lst, chrs
do wx=1 to length(chrs)
c = substr(chrs, wx, 1)
do rx=1 to length(lst) while c > substr(lst, rx, 1)
end
r1 = substr(lst, rx, 1)
if rx > length(lst) then
lst = lst || c
else if c < r1 then
lst = left(lst, rx-1) || c || substr(lst, rx)
end
return lst
endProcedure wordInsAsc
/*--- batch funktionen -----------------------------------------------*/
batchOld: procedure expose m.
parse upper arg args
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
wx = 1
do forever
w1 = word(args, wx)
if w1 = '' then
return 0
if w1 = 'ADATASET' then do
m.auftrag.dataset = word(args, wx+1)
wx = wx+2
end
else if w1 = 'DO' then do
fx = wordPos('FOR', args, wx)
if fx < 1 then
call err 'DO ohne FOR in' args
cmd = subWord(args, wx+1, fx-wx-1)
do wx=fx+1
ww = word(args, wx)
if ww = '' then
leave
m.auftrag.member = ww
say 'batch do' cmd 'for' ww '...'
call work cmd
end
end
else do
if wordPos(translate(w1), 'A AC AW') > 0 then do
drop m.auftrag.member
cmd = subword(args, wx)
end
else do
m.auftrag.member = w1
cmd = subword(args, wx+1)
end
say 'batch do' cmd 'for mbr' m.auftrag.member
call work cmd
return 0
end
end
return 0
endProcedure batchOld
/*--- create the necessary dbx libries in the specified rz -----------*/
copyDummy: procedure expose m.
parse arg rz
call copyDummy1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.AUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CDL(DUMMY)'
/* call copyDummy1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call copyDummy1 rz, 'DSN.DBX.JCL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.MASK'
/* call copyDummy1 rz, 'DSN.DBX.OVRCAT(DUMMY)' */
call copyDummy1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
return 0
endProcedure copyDummy
copyDummy1: procedure expose m.
parse arg sys, dsn
if sysDsn("'"dsn"'") <> 'OK' then
call writeDsn dsn, x, 0, 1
call csmCopy dsn, sys'/'dsn
return
/*--- die Konfiguration pro db2 Subsys -------------------------------*/
configureSubsys: procedure expose m.
parse arg rz, subsys
call mapPut e, 'subsys', subsys
if rz = 'RZ8' then
call mapPut e, 'location', 'CHROI000'subsys
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'subsys
else
call mapPut e, 'location', 'CHSKA000'subsys
return
endProcedure configureSubsys
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.iProm.2)
if rx < 1 then
m.mySub = '?noSubsys?'
else
m.mySub = substr(m.iProm.2, rx+4, 4)
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PA')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', if(rz=='RZ0', 'DSN', 'DB2@') ,
|| '.'zz'.'px'.DSNLOAD'
if toolV \== '' then do
say 'v72 nicht mehr untertstuetzt, v10 wird benutzt'
toolV = mapGet(e, 'toolVers', 10)
toolV = ''
end
call mapPut e, 'toolVers', toolV
/* if toolV == 10 then do */
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* end
else if toolV == 72 then do
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P8'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C8'
end
else
call err 'bad toolVersion' toolV
*/ if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.mySub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
else if rz = 'RR2' then do
call mapPut e, 'jobCla', 'BS0'
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ1' then
call err 'Auftrag für RZ' rz 'muss aus RZ1 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft, 'DSN.DBA.CLON.WSL'
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if make = '' then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if opt = '-R' then
nop
else if rz = 'RZ1' then
call adrIsp "edit dataset('"dsnNN"')", 4
else
call writeDsn rz'/'dsnNN, m.auftrag.
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
comMask = m.libPre'.MASK('maPr'PROT)'
impMask = m.libPre'.MASK('maPr'$subsys)'
end
else do
ow = 'S100447'
comMask = m.libPre'.MASK(PROT$trgNm)'
impMask = m.libPre'.MASK($trgNm$impNm)'
end
comIgno = m.libPre'.MASK(IGNORE)'
impIgno = ''
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
zglS = '20120210 20120511 20120810 20121109 2013???? 2014????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller pid name tel' ,
, ' comMask ' comMask ,
, ' comIgno ' comIgno ,
, ' impMask ' impMask ,
, ' impIgno ' impIgno ,
, 'source RZ8.DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%' ,
, 'target RZ8.'if(left(auftName, 2) == 'XB', 'DCVG', 'DC0G')
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
if (m.scopeSrc.rz = m.sysRz ,
| (wordPos(m.scopeSrc.rz, 'RZ8 RZZ') > 0 & m.sysRZ = 'RZ1') ,
) & m.e.qCheck \== 0 then do
if qualityCheck(getDb2Catalog('SRC')) then
if pos('F', opts) < 1 & \ m.auftrag.force then
return
else
say 'wegen Option -f Verarbeitung',
'trotz Qualitaetsfehlern'
end
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)m.e.nachtrag
m.o.0 = 0
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.subsys, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapExpAll e, o, i
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.comMask), 1)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast left(m.e.auftrag, 7)nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast left(m.e.auftrag, 7)nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call readDsn m.libSkels'Ovr)', m.ovr.
call mapExpAll e, o, ovr
call mapPut e, 'src', 'OVR'
end
if m.e.keepTgt == 0 then
call mapPut e, 'keepTgt', ''
else
call mapPut e, 'keepTgt', 'KEEPTGT,'
call readDsn m.libSkels ,
|| if(m.e.tool=='IBM', 'comp', left(m.e.tool, 1)'Com'),
|| ')', m.cmp.
call mapExpAll e, o, cmp
if m.e.tool == ca then
call caDDL o, scopeSrc, dsnGetMbr(mapGet(e, 'mask'))
end
if fun = 'ST' then do
call readDsn m.libSkels'ST)', m.st.
call mapExpAll e, o, st
end
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeTrg.rz'.'m.scopeTrg.subSys ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat",m.e.tool"Cdl") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- find the naming convention for a rz and subsystem --------------*/
namingConv: procedure expose m.
parse arg rz, subsys, var
if rz = '.' then do
if pos('.', subSys) > 0 then
call err 'namingConv old target' subsys
if pos('/', subSys) > 0 then
parse var subsys rz '/' subsys
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(subsys)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
iral = dsnAlloc(sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)')
call writeDDBegin ir
call writeDD ir, m.o.
call writeDDend 'IR'
interpret subword(irAl, 2)
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh, nac
call analyseAuftrag
if wh = 'C' then
d = copies(m.e.tool, m.e.tool \== 'IBM')'CDL'
else if wh = 'E' then
d = 'EXEJCL'
else if wh = 'J' then
d = 'JCL'
else if wh = 'S' then
d = 'SRCDDL'
else if wh = 'T' then
d = 'TRGDDL'
else if wh = 'W' then
d = 'BMCWSL'
if nac == '' then
nac = m.e.nachtrag
if wh == 'J' then
d = m.libPre'.'d'('m.e.auftrag')'
else
d = m.libPre'.'d'('left(m.e.auftrag,7)nac')'
if fun == 'E' then
call adrIsp "edit dataset('"d"')", 4
else
call adrIsp "view dataset('"d"')", 4
return
endProcedure viewEdit
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzSubSysList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if words(m.targets) > 1 then
call err 'i=import mit mehreren targets muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
if ^ m.nacImp then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck == 0 then nop
else if m.e.tool \== 'IBM' then
say 'dbaCheck for' m.e.tool 'not implemented'
else do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call readDsn m.libSkels || m.jobCard')', m.jc.
call readDsn m.libSkels || left(m.e.tool, m.e.tool\=='IBM')'Imp)',
, m.ic.
list = iListExpand(rzSubSysList, 0)
if list = '' then
call err 'no targets in list "'rzSubSysList'"'
impCnt = 0
call configureRz m.sysRz
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
call mapPut e, 'fun', strip('import'fu2 left(rzSubSysList, 30))
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
fu2 = fun fu2
m.jOut.0 = 0
call mapExpAll e, jOut, jc /* Jobcard expandieren */
j0 = m.jOut.0
rz = '?'
do lx = 1
r1 = word(list, lx)
parse var r1 r '/' subsys
if r <> rz | subsys = '' then do
if impCnt <> 0 then do
if rz <> m.sysRz then do
if symbol('m.sCdl.0') \== 'VAR' then do
call readDsn m.libSkels'sCdl)', m.sCdl.
call readDsn m.libSkels'subRz)', m.subRz.
end
if m.impMbrs == '' then
call err 'int no impMbrs'
call mapPut e, 'mbrNac',
, left(m.e.auftrag, 7)left(m.impMbrs, 1)
call mapPut e, 'toRz', m.myRz
call mapExpAll e, jOut, sCdl
jy = m.jOut.0
jx = jy-1
m.jOut.0 = jx
jla = m.jOut.jy
cx = pos(')-', m.jOut.jx)
if cx < 1 | substr(m.jout.jx, cx+2) \= '' then
call err 'bad sCdl line' jx':'m.jOut.jx
m.jOut.jx = left(m.jOut.jx,cx-1) '-'
do mx=2 to length(m.impMbrs)
call mAdd jOut, left('', cx-10)',' ,
|| left(m.e.auftrag,7) ,
|| substr(m.impMbrs, mx,1) '-'
end
call mAdd jOut, left('', cx-10)') -'
call mAdd jOut, jLa
call mapExpAll e, jOut, subRz
jy = m.jOut.0
jla = m.jOut.jy
m.jOut.0 = jy-1
call mAddSt jOut, jAft
call mAdd jOut, jLa
end
end
if subsys = '' then do
if m.jout.0 > j0 then
call writeSub jOut
return
end
rz = r
if rz = m.sysRz then do
job = jOut
m.jAft.0 = 'noUse'
end
else do
job = jAft
m.jAft.0 = 0
end
m.impMbrs = ''
call configureRz rz
impCnt = 0
call mapPut e, 'fun', 'import'fu2 rz
call mapPut e, 'fu2', fun
call configureSubsys rz
end
if length(subsys) <> 4 then
call err 'ungueltiges db2SubSys' subsys 'im import' rz
call configureSubsys rz, subsys
if rz = m.sysRz then
impCnt = impCnt + importAdd(job, subsys, opt, ic, fu2)
else if m.sysRz == 'RZ1' then
impCnt = impCnt + importAdd(job, rz'/'subsys, opt, ic, fu2)
else
call err 'cannot import into' rz 'from' m.sysRz
end
endProcedure import
/*--- add a single import to jcl in o --------------------------------*/
importAdd: procedure expose m.
parse upper arg o, rzSubSys, opt, ic, fun fu2
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ begin */
deltaNew = 1 /* abbrev(rzSubSys,'RZ1.'),
| (pos('.',rzSubSys) < 1 & m.sysRz = 'RZ1') */
if deltaNew then do /* neues delta merge verfahren */
inDdn = 'DCHG'
call mapPut e, 'cType', "''''T''''"
end
else do /* altes delta merge verfahren */
inDdn = 'SRCDDN2'
call mapPut e, 'cType', "''''C''''"
end
call mapPut e, 'inDdn', inDdn
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ end */
if opt ^= '' & opt ^= '=' then do
nachAll = opt
end
else if symbol('m.imp.rzSubSys.nachtrag') ^== 'VAR' then do
nachAll = m.compares
end
else do
if opt = '=' then
la = left(m.imp.rzSubSys.nachtrag, 1)
else
la = right(m.imp.rzSubSys.nachtrag, 1)
cx = pos(la, m.compares)
if cx < 1 then
call err 'nachtrag' la 'von' rzSubSys m.rzSubSys.change ,
'nicht in Compare Liste' m.compares
nachAll = substr(m.compares, cx + (opt ^= '='))
end
if nachAll = ' ' then do
say 'alle Nachtraege schon importiert fuer' rzSubSys
return 0
end
call mapPut e, 'mbrChg', left(m.e.auftrag, 7)right(nachAll, 1)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelSchub, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs/*'.V'mapGet(e,'toolVers')*/
else
call mapPut e, 'change',m.e.auftrag || m.imp.seq'_'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzSubSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.impMask), 1)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.impIgno))
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call bmcVarsProf 1
if m.impMbrs = '' & m.myRz \== m.sysRz then
call mapExpAll e, o, jc /* Jobcard expandieren */
m.impMbrs = charInsAsc(m.impMbrs, nachAll)
if m.e.tool = 'CA' then do
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)right(nachAll, 1)
call mapPut e, 'impMaskMbr', dsnGetMbr(mapExp(e, m.e.impMask))
call mapPut e, 'comIgnoMbr', dsnGetMbr(mapExp(e, m.e.comIgno))
call mapPut e, 'bpid', m.libPre'.CASTRAT-'mapGet(e, 'mbrNac') ,
|| '-'m.imp.seq
end
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else if deltaNew then do
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
else do
le = left('//'inDdn, 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
call readDsn m.libSkels || left(m.e.tool, 1)'Ana)', m.ia.
call mapExpAll e, o, ia
end
if wordPos(fun, 'IE') > 0 then do /* analyse step */
call readDsn m.libSkels || left(m.e.tool, 1)'Exe)', m.ie.
call mapExpAll e, o, ie
ej = mapExp(e, "'${libPre}.EXEJCL($mbrChg)'")
j.1 = 'exeJcl for' m.e.auftrag 'noch nicht generiert'
call writeDsn ej, j., 1, 1
end
call mAdd auftrag,
, addDateUs("import" rzSubsys nachAll mapGet(e, 'change') fu2)
return 1
endProcedure importAdd
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'copies(m.e.tool, m.e.tool\=='IBM') ,
|| 'CDL('left(m.e.auftrag, 7) || nt')'
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.subSys = m.mySub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.subSys = m.mySub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
m.nacImp = 0
m.e.impMask = ''
m.e.comMask = ''
m.e.tool = 'IBM'
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER COMMASK COMIGNO IMPMASK IMPIGNO' ,
'KEEPTGT DBACHECK QCHECK V72 V10 CA BMC IBM'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = m.auftrag.lx
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
w2 = translate(word(li, 2))
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if wordPos(w1, 'V72 V10') > 0 then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'subSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.subsys = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.subsys
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.mySub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . subsys nachAll chg .
subsys = translate(subsys, '/', '.')
if chgAuf <> m.e.auftrag then
if right(nachAll, 1) <> m.e.nachtrag then
call err 'aktueller Nachtrag' m.e.nachtrag ,
'aber import' nachAll 'in Zeile' lx li
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.subSys.nachtrag = nachAll
m.imp.subSys.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
/* nachtrae durchgehen und kumulieren */
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.subSys, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop subsys
say ' scope ' m.scp.0 m.scp.subsys ,
' target ' m.scopeTrg.0 m.scopeTrg.subsys
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call readDsn m.libSkels'ExVe)', m.exVe.
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, exVe, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureSubsys m.scopeTrg.rz, m.scopeTrg.subsys
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call readDsn m.libSkels'AutMa)', m.autoMap.
call readDsn m.libSkels'AutEx)', m.autoExt.
call mapExpAll e, o, autoMap
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, autoExt
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, autoExt
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, exVe, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, i, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, i, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call readDsn m.libSkels'SendJ)', m.sendJob.
call mapPut e, 'step', step
call mapExpAll e, o, sendJob
do ax=4 to arg()
call debug 'sendJob1 le' length(arg(ax)) arg(ax)'|'
call mAdd o, arg(ax) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, i
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlOConnect m.scp.subSys
else
call sqlOConnect m.scp.rz'/'m.scp.subSys
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
qualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
spezialFall: procedure expose m.
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-'left(m.st.sx, 78)
end
return
endProcedure spezialFall
/*--- mask handling initialise ---------------------------------------*/
maskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
maskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
testMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
maskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
mask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
maskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
maskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
maskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg subSys
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & subsys == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if subSys = '' then
subSys = if(subs2 == '', m.mySub, subs2)
subsys = translate(subsys, '/', '.')
call sqlConnect subSys
subsys = translate(subsys, m.mAlfLC, m.mAlfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu subSys) < 70 then
neu = left(neu, 68 - length(subSys)) '*'subSys
else if length(neu subSys) < 80 then
neu = neu '*'subSys
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end || min(strip(creator) ||'.'|| strip(name))",
"from sysibm.systables" ,
"where type = 'T' and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName"
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case when type = 'T' then 'tb'",
"when type = 'V' then 'vw'",
"when type = 'A' then 'al'",
"else '?' || type end,",
"strip(creator) || '.' || strip(name),",
"case when type = 'A' then 'for '",
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type =" quote(left(ty, 1), "'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where seqNo=1 and schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = left(m.e.auftrag, 7) || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
caDDl: procedure expose m.
parse arg o, scp, glblCh
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type == 'TS' then do
call mAdd o, ' TABLESPACE' m.sn.qual m.sn.name
call caExplode o, TABLE INDEX VIEW SYNONYM TRIGGER ,
MQTB_T MQTB_I MQTB_V MQTB_S ,
MQVW_VW MQVW_I MQVW_V MQVW_S
end
else if m.sn.type == 'VW' then do
call mAdd o, ' VIEW ' m.sn.qual m.sn.name
end
else
call err 'implement type' m.sn.type 'for ca'
end
call readDsn m.libSkels'CCO2)', m.cco2.
call mapExpAll e, o, cco2
call mAdd o, ' GLBLNAME ' glblCh ,
, ' GLBLCRTR DBX'
glblDsn = m.libPre".caGlblCh("glblCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' glblCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBL.'
call mAddSt o, glbl
return
endProcedure caDDL
caExplode: procedure expose m.
parse arg o, expl
do wx=1
e1 = word(expl, wx)
if e1 == '' then
return
call mAdd o, ' EXPLODE' e1
end
endProcedure caExplode
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.subsys \== m.scopeTrg.subsys then
call err 'bmc compare on different subsystems not implemented'
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlOConnect m.scp.subSys
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
m.sqlO.cursors = left('', 200)
call jIni
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, m.sql.cx.type
if m.sql.cx.type \== '' then
m.sql.cx.type = class4Name(m.sql.cx.type)
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
return sqlCsmUpdate(cx, src, retOk)
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
return sqlCsmUpdate(cx, src, retOk)
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlOConnect: procedure expose m.
parse arg sys, retCon
call sqlOIni
return sqlConnect(sys, retCon)
endProcedure sqlOConnect
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
ggRet = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
ggRet = ggRet w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if sub == '' then
call sqlOConnect
else if sub \== m.sql.connected then
call sqlConnect sub
return sqlStmts(src, strip(ggRet), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
's' ==> spufi formatting (window 72) otherwise linebreak */
sqlStmts: procedure expose m.
parse arg src, ggRet, opt
dlm = ';'
isStr = oStrOrObj(src, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call sbSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
w1 = translate(word(s1, 1))
if w1 == 'TERMINATOR' then do
dlm = strip(substr(m.s.val, 12))
if length(dlm) \== 1 then
call scanErr s, 'bad terminator' dlm 'in' strip(m.s.val)
iterate
end
call out sqlStmt(s1, ggRet, opt)
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = 'sqlCode' r1
if wordPos(m.sql.cx.fun, 'DELETE INSERT UPDATE') > 0 then
res = res',' m.sql.cx.updateCount 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
else if m.sql.cx.updateCount\=='' & m.sql.cx.updateCount\=0 then
res = res',' m.sql.cx.updateCount 'rows updated'
aa = strip(src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = m.rdr.rowCount 'rows fetched'
end
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
call sqlFreeCursor cx
return res':' aa
endProceduire sqlStmt
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
if pos('-', ggRet) < 1 & fun = 'DROP' then
ggRet = -204 ggRet
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, ggRet, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.mAlfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%+Q\s'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec('describe cursor :crN into :M.SQL.'crs'.D')
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 49)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlo.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlo.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%+Q v, f ')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = mNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conSSID
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay 'sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay sqlMsg(sqlCA2rx(sqlCa)), ,'w'
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
f = m.sql.cx.type
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
if f \== '' then do
f = f'.FLDS'
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
/*--- initialize sqlRx (belongs to sqlQ, but currently only one|) ----*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlCAMsg = 0
m.sqlSuMsg = 2
call sqlPushRetOk
m.sql.ini = 1
m.sql.conType = ''
return 0
endProcedure sqlIni
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlOIni
hst = ''
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
cTy = 'Rx'
end
if m.sql.conType == cTy & m.sqlHost==hst & m.sqlConSSID == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.conSSID = sys
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conhost = ''
m.sql.conSSID = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
if retOk == '' then
retOk = 100 m.sqlRetOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, ggRet)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, ggRet)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, ggRet)
end
res = sqlExec(src, ggRet)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | fun == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = sqlGetCursor()
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = sqlGetCursor()
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2One
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
s = ''
src = inp2str(src, '%+Q\s')
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
return sqlExec('prepare s'cx s 'from :src', ggRetOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cn = translate(word(sNa, 1))
if cn == '' | symbol('sqlVarName.cn') == 'VAR' then
cn = 'COL'kx
sqlVarName.cn = 1
return cn
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
sqlHandleRCSqlCode:
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
/*???lse if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then*/
else if (sqlCode <> 0 | sqlWarn.0^==' ') & pos('w',ggRetOk)<1 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlDisconnect
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' ,
if(m.sql.conHost=='',,m.sql.conHost'/'),
|| m.sql.conSSID', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca:
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.mAlfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sql end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
if fmt == '' then
fmt = '%+Q\s'
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%-Qnxt', m.line)
end
call jClose m
fEnd = 'F.FORMAT.'fmt'%-Qend'
return res || m.fEnd
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
res = ''
st = ''
bx = m.m.pos
do forever
call sbUntil m, '"''-/'stop
if sbEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if sbLit(m, ''' "') then do
c1 = sbPrev(m)
do while \ sbStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call sbChar m, 1
if res <> '' then
return res
bx = m.m.pos
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return res
end
endProcedure jCatSqlNext
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
call outDst
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- out interface of j --------------------------------------------*/
outIni: procedure expose m.
call jIni
return
endProcedure outIni
outDst: procedure expose m.
parse arg wrt
oldOut = m.j.out
if wrt == '' then
wrt = jOpen(oNew('JSay'), '>')
m.j.out = wrt
return oldOut
endProcedure outDst
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if classInheritsOf(ggCla, class4Name('JBuf')) ,
& m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
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
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || fPlus(fmt 'nxt', m.st.sx)
end
return res || fFld(fmt 'end')
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 || '.'
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.m.area.0 = 0
call mNewArea
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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBX1123) cre=2012-11-26 mod=2012-11-26-16.20.26 A540769 ---
/* rexx ****************************************************************
synopsis: DBX fun args v1.4
edit macro fuer CS Nutzung von DB2 AdminTool 10.1
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr naechste AuftragsId suchen fuer praefix pr
aa: anzueigen, aw, ac entsprechendes Member editieren
n, nt neuen Auftrag erstellen (nt = test)
q subSys? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* ergaenzt scope Zeile mit infos, z.B tb -> ts
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren,
sonst werden alle expandiert
* funktioniert nicht nur in Auftrag
falls SubSys angegeben wird da gesucht sonst DBAF/DBOF
c opt? compare source gegen target
i subs nct changes in Db2Subsystem subSys importieren
subs = sub(,sub)*: Liste von Subsystemen/Umgebungen
sub: DBAF (lokal), RR2/DBOF (im PTA), RZ8(betr. Subsys)
ET, IT, PA (pta), PR (prod), pq(pta+rq2)
==> Rz/Subsys des PromotionPaths
nct: Nachtraege:
leer: noch nicht in dieses SubSys importierte
= : vom letzten import plus neue
89A : Nachtraege 8, 9 und A
v opt? version files erstellen für altes Verfahren
vc vj vs vt vy ec ej es et ey subsys? nt?
view or edit cdl, jcl, srcDdl, trgDdl, strategY
sw rz? WSL ins RZ rz schicken und clonen, ohne rz multiclone
opt? Optionale Optionen =, -f, -=f etc. (fuer c, v, st)
= statt aktuelle source aus Db2 extrahieren
letzte extrahierte Version als Source brauchen
-f force: ignoriere QualitaetsVerletzungen
cloneWsl dbaMulti Funktionalitaet ist hier implementiert
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: v10, v72, keeptgt 0, qCheck 0, dbaCheck 0
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
Optionen: ca, bmc, ibm
Funktionen: ia (imp+ana), ie (ia+exe), ee,ve (exejcl), ew,vw (wsl)
************************************************************************
9.11.2012 W. Keller ey und vy für view/edit strategy
*/ /* end of help
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset h
if sysvar(sysispf) = 'ACTIVE' then
call adrIsp 'Control errors return'
call jIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call setIf
call stepGroup 1
m.auftrag.force = 0
do while abbrev(fun, '-')
r = substr(fun, 3)
if abbrev(fun, '-A') then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then do
m.auftrag.force = 1
end
else do
call err 'bad opt' fun 'in' wArgs
end
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
end
if 1 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
call mapPut e, 'rexxLib', 'ORG.U0009.B0106.KIDI63.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if wordPos(fun, 'AA AC AW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if fun = 'COPYDUMMY' then
return copyDummy(args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
call memberOpt
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if wordPos(fun, 'VC VE VJ VS VT VW VY EC EE EJ ES ET EW EY') ,
> 0 then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
m.uNa = 'Marc'
else if m.uId = 'A390880' then
m.uNa = 'Martin'
else if m.uId = 'A540769' then
m.uNa = 'Walter'
else if m.uId = 'A666308' then
m.uNa = 'Frank'
else if m.uId = 'A754048' then
m.uNa = 'Alessandro'
else if m.uId = 'A790472' then
m.uNa = 'Agnes'
else if m.uId = 'A828386' then
m.uNa = 'Reni'
else
m.uNa = m.uId
m.scopeTypes = 'DB TS TB VW AL IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths */
m.iProm.1 = 'ET IT PQ PA PR'
m.iProm.2 = 'RZ1/DBAF,RZ8/DC0G RZ1/DBTF,RZ8/DD0G,RZZ/DE0G' ,
'RQ2/DBOF,RR2/DBOF RR2/DBOF RZ2/DBOF'
m.iProm.3 = 'RZ1/DBBA,RZ8/DCVG RZ1/DVTB,RZ8/DDVG,RZZ/DEVG' ,
'RQ2/DVBP,RR2/DVBP RR2/DVBP RZ2/DVBP'
m.iProm.0 = 3
return
endProcedure dbxIni
/*--- expand the import target list entered by the user
to a list or rz/subsys, with mySub first and the rest sorted*/
iListExpand: procedure expose m.
parse upper arg srcList
tl = iPromExpand(translate(space(srcList, 0), '/ ', '.,'))
local = ''
remote = ''
do tx=1 to words(tl)
t1 = word(tl, tx)
if abbrev(t1, m.myRz'/') then
local = wordInsAsc(local, t1)
else
remote = wordInsAsc(remote, t1)
end
return local remote
endProcedure iListExpand
/*--- expand a target using iProm infos to a list of rz/subsys -------*/
iPromExpand: procedure expose m.
parse arg inp
if words(inp) <> 1 then do /* several words, expand each */
out = ''
do wx=1 to words(inp)
out = out iPromExpand(word(inp, wx))
end
return out
end
if pos('/', inp) > 0 then /* already expanded */
return inp
if inp == '?*?' then do /* find current promotionPath */
tg = m.scopeTrg.rz'/'m.scopeTrg.subSys
do tx=2 to m.iProm.0
if pos(tg, m.iProm.tx) > 0 then
return m.iprom.tx
end
call err 'target' tg 'not in any PromotionPath'
end
px = wordPos(inp, m.iProm.1) /* one promotion environment */
if px > 0 then
return translate(word(iPromExpand('?*?'), px), ' ', ',')
if length(inp) = 4 then /* prepend rz to subsys */
return m.myRz'/'inp
/* all subsys that match something */
alOr = iPromExpand('?*?')
all = translate(alOr, ' ', ',')
out = ''
do ax = 1 to words(all)
if pos(inp, word(all, ax)) > 0 then
if wordPos(word(all, ax), out) < 1 then
out = out word(all, ax)
end
if out \== '' then
return out
call err 'inp' inp ' not found in promotionPath' alOr
endProcedure iPromExpand
wordInsAsc: procedure expose m.
parse arg lst, wrds
do wx=1
w = word(wrds, wx)
if w == '' then
return space(lst, 1)
do rx=1 to words(lst) while w > word(lst, rx)
end
r1 = word(lst, rx)
if r1 == '' then
lst = lst w
else if w < r1 then
lst = subWord(lst, 1, rx-1) w subWord(lst, rx)
end
endProcedure wordInsAsc
charInsAsc: procedure expose m.
parse arg lst, chrs
do wx=1 to length(chrs)
c = substr(chrs, wx, 1)
do rx=1 to length(lst) while c > substr(lst, rx, 1)
end
r1 = substr(lst, rx, 1)
if rx > length(lst) then
lst = lst || c
else if c < r1 then
lst = left(lst, rx-1) || c || substr(lst, rx)
end
return lst
endProcedure wordInsAsc
/*--- batch funktionen -----------------------------------------------*/
batchOld: procedure expose m.
parse upper arg args
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
wx = 1
do forever
w1 = word(args, wx)
if w1 = '' then
return 0
if w1 = 'ADATASET' then do
m.auftrag.dataset = word(args, wx+1)
wx = wx+2
end
else if w1 = 'DO' then do
fx = wordPos('FOR', args, wx)
if fx < 1 then
call err 'DO ohne FOR in' args
cmd = subWord(args, wx+1, fx-wx-1)
do wx=fx+1
ww = word(args, wx)
if ww = '' then
leave
m.auftrag.member = ww
say 'batch do' cmd 'for' ww '...'
call work cmd
end
end
else do
if wordPos(translate(w1), 'A AC AW') > 0 then do
drop m.auftrag.member
cmd = subword(args, wx)
end
else do
m.auftrag.member = w1
cmd = subword(args, wx+1)
end
say 'batch do' cmd 'for mbr' m.auftrag.member
call work cmd
return 0
end
end
return 0
endProcedure batchOld
/*--- create the necessary dbx libries in the specified rz -----------*/
copyDummy: procedure expose m.
parse arg rz
call copyDummy1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.AUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CDL(DUMMY)'
/* call copyDummy1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call copyDummy1 rz, 'DSN.DBX.JCL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.MASK'
/* call copyDummy1 rz, 'DSN.DBX.OVRCAT(DUMMY)' */
call copyDummy1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
return 0
endProcedure copyDummy
copyDummy1: procedure expose m.
parse arg sys, dsn
if sysDsn("'"dsn"'") <> 'OK' then
call writeDsn dsn, x, 0, 1
call csmCopy dsn, sys'/'dsn
return
/*--- die Konfiguration pro db2 Subsys -------------------------------*/
configureSubsys: procedure expose m.
parse arg rz, subsys
call mapPut e, 'subsys', subsys
if rz = 'RZ8' then
call mapPut e, 'location', 'CHROI000'subsys
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'subsys
else
call mapPut e, 'location', 'CHSKA000'subsys
return
endProcedure configureSubsys
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG0'
rx = pos(rz'/', m.iProm.2)
if rx < 1 then
m.mySub = '?noSubsys?'
else
m.mySub = substr(m.iProm.2, rx+4, 4)
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PA')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', if(rz=='RZ0', 'DSN', 'DB2@') ,
|| '.'zz'.'px'.DSNLOAD'
call mapPut e, 'capref', 'DSN.CADB2.'zz'.P0'
call mapPut e, 'caload', 'DSN.CADB2.'zz'.P0.CDBALOAD'
call mapPut e, 'cacr', DBX
if toolV \== '' then do
say 'v72 nicht mehr untertstuetzt, v10 wird benutzt'
toolV = mapGet(e, 'toolVers', 10)
toolV = ''
end
call mapPut e, 'toolVers', toolV
/* if toolV == 10 then do */
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* end
else if toolV == 72 then do
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P8'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C8'
end
else
call err 'bad toolVersion' toolV
*/ if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.mySub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
else if rz = 'RR2' then do
call mapPut e, 'jobCla', 'BS0'
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ1' then
call err 'Auftrag für RZ' rz 'muss aus RZ1 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft, 'DSN.DBA.CLON.WSL'
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if pos(make, 'CW') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if opt = '-R' then
nop
else if rz = 'RZ1' then
call adrIsp "edit dataset('"dsnNN"')", 4
else
call writeDsn rz'/'dsnNN, m.auftrag.
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
comMask = m.libPre'.MASK('maPr'PROT)'
impMask = m.libPre'.MASK('maPr'$subsys)'
end
else do
ow = 'S100447'
comMask = m.libPre'.MASK(PROT$trgNm)'
impMask = m.libPre'.MASK($trgNm$impNm)'
end
comIgno = m.libPre'.MASK(IGNORE)'
impIgno = ''
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
zglS = '20130208 20130510 20130809 20131108 2014???? 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller pid name tel' ,
, ' comMask ' comMask ,
, ' comIgno ' comIgno ,
, ' impMask ' impMask ,
, ' impIgno ' impIgno ,
, 'source RZ8.DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%' ,
, 'target RZ8.'if(left(auftName, 2) == 'XB', 'DCVG', 'DC0G')
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
if (m.scopeSrc.rz = m.sysRz ,
| (wordPos(m.scopeSrc.rz, 'RZ8 RZZ') > 0 & m.sysRZ = 'RZ1') ,
) & m.e.qCheck \== 0 then do
if qualityCheck(getDb2Catalog('SRC')) then
if pos('F', opts) < 1 & \ m.auftrag.force then
return
else
say 'wegen Option -f Verarbeitung',
'trotz Qualitaetsfehlern'
end
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)m.e.nachtrag
m.o.0 = 0
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.subsys, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapExpAll e, o, i
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.comMask), 1)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast left(m.e.auftrag, 7)nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast left(m.e.auftrag, 7)nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call readDsn m.libSkels'Ovr)', m.ovr.
call mapExpAll e, o, ovr
call mapPut e, 'src', 'OVR'
end
if m.e.keepTgt == 0 then
call mapPut e, 'keepTgt', ''
else
call mapPut e, 'keepTgt', 'KEEPTGT,'
call readDsn m.libSkels ,
|| if(m.e.tool=='IBM', 'comp', left(m.e.tool, 1)'Com'),
|| ')', m.cmp.
if m.e.tool == ca then
call caDDL o, cmp, scopeSrc, dsnGetMbr(mapGet(e, 'mask'))
else
call mapExpAll e, o, cmp
end
if fun = 'ST' then do
call readDsn m.libSkels'ST)', m.st.
call mapExpAll e, o, st
end
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeTrg.rz'.'m.scopeTrg.subSys ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat",m.e.tool"Cdl") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- find the naming convention for a rz and subsystem --------------*/
namingConv: procedure expose m.
parse arg rz, subsys, var
if rz = '.' then do
if pos('.', subSys) > 0 then
call err 'namingConv old target' subsys
if pos('/', subSys) > 0 then
parse var subsys rz '/' subsys
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(subsys)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
iral = dsnAlloc(sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)')
call writeDDBegin ir
call writeDD ir, m.o.
call writeDDend 'IR'
interpret subword(irAl, 2)
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh, nac
call analyseAuftrag
if wh = 'Y' then do
if length(word(nac, 1)) == 4 then
d = word(nac, 1)
else
d = m.imp.last
n1 = right(m.imp.d.nachtrag, 1)
if nac <> '' then
if length(word(nac, words(nac))) == 1 then
n1 = word(nac, words(nac))
d = m.libPre || d'.STRY('left(m.e.auftrag,7)n1')'
end
else do
if wh = 'C' then
d = copies(m.e.tool, m.e.tool \== 'IBM')'CDL'
else if wh = 'E' then
d = 'EXEJCL'
else if wh = 'J' then
d = 'JCL'
else if wh = 'S' then
d = 'SRCDDL'
else if wh = 'T' then
d = 'TRGDDL'
else if wh = 'W' then
d = 'BMCWSL'
if nac == '' then
nac = m.e.nachtrag
if wh == 'J' then
d = m.libPre'.'d'('m.e.auftrag')'
else
d = m.libPre'.'d'('left(m.e.auftrag,7)nac')'
end
if fun == 'E' then
call adrIsp "edit dataset('"d"')", 4
else
call adrIsp "view dataset('"d"')", 4
return
endProcedure viewEdit
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzSubSysList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if words(m.targets) > 1 then
call err 'i=import mit mehreren targets muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
if ^ m.nacImp then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck == 0 then nop
else if m.e.tool \== 'IBM' then
say 'dbaCheck for' m.e.tool 'not implemented'
else do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
call readDsn m.libSkels || m.jobCard')', m.jc.
call readDsn m.libSkels || left(m.e.tool, m.e.tool\=='IBM')'Imp)',
, m.ic.
list = iListExpand(rzSubSysList, 0)
if list = '' then
call err 'no targets in list "'rzSubSysList'"'
impCnt = 0
call configureRz m.sysRz
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
call mapPut e, 'fun', strip('import'fu2 left(rzSubSysList, 30))
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
m.e.impMasks = ''
fu2 = fun fu2
m.jOut.0 = 0
call mapExpAll e, jOut, jc /* Jobcard expandieren */
call stepGroup 1
j0 = m.jOut.0
rz = '?'
do lx = 1
r1 = word(list, lx)
parse var r1 r '/' subsys
if r <> rz | subsys = '' then do
if impCnt <> 0 then do
if rz <> m.sysRz then do
if symbol('m.sCdl.0') \== 'VAR' then do
call readDsn m.libSkels'sCdl)', m.sCdl.
call readDsn m.libSkels'subRz)', m.subRz.
end
if m.impMbrs == '' then
call err 'int no impMbrs'
call mapPut e, 'mbrNac',
, left(m.e.auftrag, 7)left(m.impMbrs, 1)
call mapPut e, 'toRz', m.myRz
call mapExpAll e, jOut, sCdl
jy = m.jOut.0
jx = jy-1
m.jOut.0 = jx
jla = m.jOut.jy
cx = pos(')-', m.jOut.jx)
if cx < 1 | substr(m.jout.jx, cx+2) \= '' then
call err 'bad sCdl line' jx':'m.jOut.jx
m.jOut.jx = left(m.jOut.jx,cx-1) '-'
do mx=2 to length(m.impMbrs)
call mAdd jOut, left('', cx-10)',' ,
|| left(m.e.auftrag,7) ,
|| substr(m.impMbrs, mx,1) '-'
end
call mAdd jOut, left('', cx-10)') -'
call mAdd jOut, jLa
call mapExpAll e, jOut, subRz
jy = m.jOut.0
jla = m.jOut.jy
m.jOut.0 = jy-1
call mAddSt jOut, jAft
call mAdd jOut, jLa
end
end
if subsys = '' then do
if m.jout.0 > j0 then
call writeSub jOut
return
end
rz = r
if rz = m.sysRz then do
job = jOut
m.jAft.0 = 'noUse'
end
else do
job = jAft
m.jAft.0 = 0
end
m.impMbrs = ''
call configureRz rz
impCnt = 0
call mapPut e, 'fun', 'import'fu2 rz
call mapPut e, 'fu2', fun
call configureSubsys rz
end
if length(subsys) <> 4 then
call err 'ungueltiges db2SubSys' subsys 'im import' rz
call configureSubsys rz, subsys
if rz = m.sysRz then
impCnt = impCnt + importAdd(job, subsys, opt, ic, fu2)
else if m.sysRz == 'RZ1' then
impCnt = impCnt + importAdd(job, rz'/'subsys, opt, ic, fu2)
else
call err 'cannot import into' rz 'from' m.sysRz
end
endProcedure import
/*--- add a single import to jcl in o --------------------------------*/
importAdd: procedure expose m.
parse upper arg o, rzSubSys, opt, ic, fun fu2
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ begin */
deltaNew = 1 /* abbrev(rzSubSys,'RZ1.'),
| (pos('.',rzSubSys) < 1 & m.sysRz = 'RZ1') */
if deltaNew then do /* neues delta merge verfahren */
inDdn = 'DCHG'
call mapPut e, 'cType', "''''T''''"
end
else do /* altes delta merge verfahren */
inDdn = 'SRCDDN2'
call mapPut e, 'cType', "''''C''''"
end
call mapPut e, 'inDdn', inDdn
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ end */
if opt ^= '' & opt ^= '=' then do
nachAll = opt
end
else if symbol('m.imp.rzSubSys.nachtrag') ^== 'VAR' then do
nachAll = m.compares
end
else do
if opt = '=' then
la = left(m.imp.rzSubSys.nachtrag, 1)
else
la = right(m.imp.rzSubSys.nachtrag, 1)
cx = pos(la, m.compares)
if cx < 1 then
call err 'nachtrag' la 'von' rzSubSys m.rzSubSys.change ,
'nicht in Compare Liste' m.compares
nachAll = substr(m.compares, cx + (opt ^= '='))
end
if nachAll = ' ' then do
say 'alle Nachtraege schon importiert fuer' rzSubSys
return 0
end
call mapPut e, 'mbrChg', left(m.e.auftrag, 7)right(nachAll, 1)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelSchub, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs/*'.V'mapGet(e,'toolVers')*/
else
call mapPut e, 'change',m.e.auftrag || m.imp.seq'_'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzSubSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.impIgno))
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call bmcVarsProf 1
if m.impMbrs = '' & m.myRz \== m.sysRz then
call mapExpAll e, o, jc /* Jobcard expandieren */
m.impMbrs = charInsAsc(m.impMbrs, nachAll)
if m.e.tool = 'CA' then do
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)right(nachAll, 1)
call mapPut e, 'stry', mapGet(e, 'mbrNac')
call mapPut e, 'impMaskMbr', dsnGetMbr(mapExp(e, m.e.impMask))
call mapPut e, 'comIgnoMbr', dsnGetMbr(mapExp(e, m.e.comIgno))
call mapPut e, 'ddlin', m.libPre'.CACDL('mapGet(e, 'mbrNac')')'
call mapPut e, 'bpid', m.libPre'.CASTRAT-'mapGet(e, 'mbrNac') ,
|| '-'m.imp.seq
end
impM = translate(mapExp(e, m.e.impMask))
m.e.impMbr = dsnGetMbr(impM)
call mapPut e, 'mask', shrDummy(impM, 1)
if m.e.impMbr = '' | m.e.tool \== 'CA' then do
end
else do
mapCdl = m.libPre'MAP.'m.e.impMbr'('mapGet(e, 'mbrNac')')'
call mapPut e, 'ddlout', mapCdl
if wordPos(m.e.impMbr, m.e.impMasks) < 1 then do
call importMapping o, m.e.impMbr, ic, nachAll, deltaNew,
, mapCdl
call stepGroup
m.e.impMasks = m.e.impMasks m.e.impMbr
end
call mapPut e, 'ddlin', mapCdl
call mapPut e, 'impMaskMbr', ''
end
call importExpand o, ic, nachAll, deltaNew
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
call addIf o
call readDsn m.libSkels || left(m.e.tool, 1)'Ana)', m.ia.
call mapExpAll e, o, ia
call caGlbChg o, dsnGetMbr(mapGet(e, 'mask'))
call addIf o, 'end'
call setIf 'ANA', 0 4
end
if wordPos(fun, 'IE') > 0 then do /* execute step */
call readDsn m.libSkels || left(m.e.tool, 1)'Exe)', m.ie.
call addIf o
call mapExpAll e, o, ie
ej = mapExp(e, "'${libPre}.EXEJCL($mbrChg)'")
call addIf o, 'end'
call setIf 'RUN'
j.1 = 'exeJcl for' m.e.auftrag 'noch nicht generiert'
call writeDsn ej, j., 1, 1
end
if m.e.tool <> ibm then
ifl2 = overlay(' ', m.ifLine, pos('IF', m.ifLine))
ifl2 = overlay(') THEN', ifl2, pos('THEN', ifl2))
call mAdd o, '// IF ABEND OR NOT (', ifl2,
, '//PERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
call mAdd auftrag,
, addDateUs("import" rzSubsys nachAll mapGet(e, 'change') fu2)
call stepGroup
return 1
endProcedure importAdd
stepGroup: procedure expose m.
parse arg f
if f == 1 then
no = 1
else
no = m.e.stepNo + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return
endProcedure stepGroup
setIf: procedure expose m.
parse arg stp, codes
if stp == '' then
li = ''
else do
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = '// IF' stp'.RUN AND'
pr = '('
if codes == '' then
codes = 0
do cx=1 to words(codes)
li = li pr stp'.RC='word(codes,cx)
pr = 'OR'
end
li = li ') THEN'
end
if length(li) > 72 then
call err 'if too long' li
m.ifLine = li
if li == '' then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt
if m.ifLine == '' then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else
call mAdd o, m.ifLine
return
endProcedure addIf
importExpand: procedure expose m.
parse arg o, ic, nachAll, deltaNew
call addIf o
if m.e.tool = 'CA' then
call mapPut e, 'impMaskMbr', 'DBXEQ'
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else if deltaNew then do
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
else do
le = left('//'inDdn, 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
if m.e.tool = 'CA' & mapGet(e, 'impMaskMbr') == '' then
m.o.0 = m.o.0 -2 /* die beiden maskZeilen entfernen */
call addIf o, 'end'
call setIf 'AUTO'
return
endProcedure importExpand
importMapping: procedure expose m.
parse arg o, msk, ic, nachAll, deltaNew, mapCdl
say '???adding impMbr' msk
call addIf o
mStry = left(m.e.auftrag, 7)'#'
call mapPut e, 'mStry', mStry
interpret subword(dsnAlloc(mapCdl '::F'), 2)
call mAdd o,'//****** importMasking' mask 'begin ???????'
call readDsn m.libSkels'CMAP)', m.im.
call mapExpAll e, o, im
call mapPut e, 'ddlout', mapCdl
call caGlbChg o, mapGet(e, 'impMaskMbr')
call mAdd o,'//****** importMasking' mask 'end ???????'
call setIf 'MANA', 0
call addIf o, 'end'
return
endProcedure importMapping
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'copies(m.e.tool, m.e.tool\=='IBM') ,
|| 'CDL('left(m.e.auftrag, 7) || nt')'
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.subSys = m.mySub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.subSys = m.mySub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
m.nacImp = 0
m.e.impMask = ''
m.e.comMask = ''
m.e.tool = 'IBM'
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER COMMASK COMIGNO IMPMASK IMPIGNO' ,
'KEEPTGT DBACHECK QCHECK V72 V10 CA BMC IBM'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = m.auftrag.lx
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
w2 = translate(word(li, 2))
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if wordPos(w1, 'V72 V10') > 0 then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'subSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.subsys = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.subsys
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.mySub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . subsys nachAll chg .
subsys = translate(subsys, '/', '.')
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = subSys
m.imp.subSys.nachtrag = nachAll
m.imp.subSys.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
/* nachtrae durchgehen und kumulieren */
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.subSys, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop subsys
say ' scope ' m.scp.0 m.scp.subsys ,
' target ' m.scopeTrg.0 m.scopeTrg.subsys
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call readDsn m.libSkels'ExVe)', m.exVe.
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, exVe, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureSubsys m.scopeTrg.rz, m.scopeTrg.subsys
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call readDsn m.libSkels'AutMa)', m.autoMap.
call readDsn m.libSkels'AutEx)', m.autoExt.
call mapExpAll e, o, autoMap
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, autoExt
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, autoExt
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, exVe, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, i, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, i, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call readDsn m.libSkels'SendJ)', m.sendJob.
call mapPut e, 'step', step
call mapExpAll e, o, sendJob
do ax=4 to arg()
call debug 'sendJob1 le' length(arg(ax)) arg(ax)'|'
call mAdd o, arg(ax) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, i
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlOConnect m.scp.subSys
else
call sqlOConnect m.scp.rz'/'m.scp.subSys
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
qualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
spezialFall: procedure expose m.
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-'left(m.st.sx, 78)
end
return
endProcedure spezialFall
/*--- mask handling initialise ---------------------------------------*/
maskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
maskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
testMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
maskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
mask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
maskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
maskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
maskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg subSys
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & subsys == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if subSys = '' then
subSys = if(subs2 == '', m.mySub, subs2)
subsys = translate(subsys, '/', '.')
call sqlConnect subSys
subsys = translate(subsys, m.mAlfLC, m.mAlfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu subSys) < 70 then
neu = left(neu, 68 - length(subSys)) '*'subSys
else if length(neu subSys) < 80 then
neu = neu '*'subSys
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end || min(strip(creator) ||'.'|| strip(name))",
"from sysibm.systables" ,
"where type = 'T' and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName"
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case when type = 'T' then 'tb'",
"when type = 'V' then 'vw'",
"when type = 'A' then 'al'",
"else '?' || type end,",
"strip(creator) || '.' || strip(name),",
"case when type = 'A' then 'for '",
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type =" quote(left(ty, 1), "'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where seqNo=1 and schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = left(m.e.auftrag, 7) || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
trace ?r
parse arg o, cco1, scp, GlbChg
if m.sysRz = m.scp.rz then do
call caDD1 o, cco1, scp, GlbChg
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.CACDL($mbrNac)'))
call caDD1 o, cco1, scp, GlbChg
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, cco1, scp, GlbChg
call mapPut e, 'user', userid()
call mapExpAll e, o, cco1
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type == 'DB' then
call caEx o, 'DATABASE' '=' m.sn.name, 'db'
else if m.sn.type == 'IX' then
call caEx o, 'INDEX' m.sn.qual m.sn.name, 'i'
else if m.sn.type == 'TS' then
call caEx o, 'TABLESPACE' m.sn.qual m.sn.name, 'ts'
else if m.sn.type == 'VW' then
call caEx o, 'VIEW' m.sn.qual m.sn.name, 'v'
else
call err 'implement type' m.sn.type 'for ca'
end
call readDsn m.libSkels'CCO2)', m.cco2.
call mapExpAll e, o, cco2
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, glbchg, cr
if glbChg == '' then
return
/* call mAdd o, ' GLBLNAME ' GlbChg, nein, ins member schreiben ???
, ' GLBLCRTR ' mapGet(e, 'cacr') */
glblDsn = m.libPre".caGlbChg("GlbChg")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' GlbChg':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBL.'
call mAddSt o, glbl
return
endProcedure caGlblChg
/*--- add explode options depending on object type -------------------*/
caEx: procedure expose m.
parse arg o, oLine, ty
call mAdd o, '' oLine
call caE1 o, ty, 'e TABLESPACE db'
call caE1 o, ty, 'e TABLE db ts'
call caE1 o, ty, 'e INDEX db ts t'
call caE1 o, ty, 'e VIEW db ts t v'
call caE1 o, ty, 'e SYNONYM db ts t v'
call caE1 o, ty, 'e TRIGGER db ts t v'
call caE1 o, ty, 'e MQTB_T db ts t v'
call caE1 o, ty, 'e MQTB_I db ts t v'
call caE1 o, ty, 'e MQTB_V db ts t v'
call caE1 o, ty, 'e MQTB_S db ts t v'
call caE1 o, ty, 'e MQVW_VW db ts t v'
call caE1 o, ty, 'e MQVW_I db ts t v'
call caE1 o, ty, 'e MQVW_V db ts t v'
call caE1 o, ty, 'e MQVW_S db ts t v'
call caE1 o, ty, 'i MQVW_VW i'
return
endProcedure caEx
caE1: procedure expose m.
parse arg o, ty, v1 v2 types
if v1 == 'e' then
e = 'EXPLODE'
else if v1 == 'i' then
e = 'IMPLODE'
else
call err 'bad explode' v1 'in caE1('o',' ty',' v1 v2 types')'
if wordPos(ty, types) > 0 then
call mAdd o, ' 'left(e, 11) v2
return
endProcedure caE1
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.subsys \== m.scopeTrg.subsys then
call err 'bmc compare on different subsystems not implemented'
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlOConnect m.scp.subSys
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
m.sqlO.cursors = left('', 200)
call jIni
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, m.sql.cx.type
if m.sql.cx.type \== '' then
m.sql.cx.type = class4Name(m.sql.cx.type)
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
return sqlCsmUpdate(cx, src, retOk)
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
return sqlCsmUpdate(cx, src, retOk)
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlOConnect: procedure expose m.
parse arg sys, retCon
call sqlOIni
return sqlConnect(sys, retCon)
endProcedure sqlOConnect
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
ggRet = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
ggRet = ggRet w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if sub == '' then
call sqlOConnect
else if sub \== m.sql.connected then
call sqlConnect sub
return sqlStmts(src, strip(ggRet), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
's' ==> spufi formatting (window 72) otherwise linebreak */
sqlStmts: procedure expose m.
parse arg src, ggRet, opt
dlm = ';'
isStr = oStrOrObj(src, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call sbSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
w1 = translate(word(s1, 1))
if w1 == 'TERMINATOR' then do
dlm = strip(substr(m.s.val, 12))
if length(dlm) \== 1 then
call scanErr s, 'bad terminator' dlm 'in' strip(m.s.val)
iterate
end
call out sqlStmt(s1, ggRet, opt)
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = 'sqlCode' r1
if wordPos(m.sql.cx.fun, 'DELETE INSERT UPDATE') > 0 then
res = res',' m.sql.cx.updateCount 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
else if m.sql.cx.updateCount\=='' & m.sql.cx.updateCount\=0 then
res = res',' m.sql.cx.updateCount 'rows updated'
aa = strip(src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = m.rdr.rowCount 'rows fetched'
end
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
call sqlFreeCursor cx
return res':' aa
endProceduire sqlStmt
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
if pos('-', ggRet) < 1 & fun = 'DROP' then
ggRet = -204 ggRet
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, ggRet, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.mAlfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%+Q\s'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec('describe cursor :crN into :M.SQL.'crs'.D')
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 49)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlo.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlo.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%+Q v, f ')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = mNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conSSID
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay 'sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay sqlMsg(sqlCA2rx(sqlCa)), ,'w'
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
f = m.sql.cx.type
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
if f \== '' then do
f = f'.FLDS'
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
/*--- initialize sqlRx (belongs to sqlQ, but currently only one|) ----*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlCAMsg = 0
m.sqlSuMsg = 2
call sqlPushRetOk
m.sql.ini = 1
m.sql.conType = ''
return 0
endProcedure sqlIni
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlOIni
hst = ''
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
cTy = 'Rx'
end
if m.sql.conType == cTy & m.sqlHost==hst & m.sqlConSSID == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.conSSID = sys
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conhost = ''
m.sql.conSSID = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
if retOk == '' then
retOk = 100 m.sqlRetOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, ggRet)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, ggRet)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, ggRet)
end
res = sqlExec(src, ggRet)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | fun == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = sqlGetCursor()
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = sqlGetCursor()
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2One
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
s = ''
src = inp2str(src, '%+Q\s')
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
return sqlExec('prepare s'cx s 'from :src', ggRetOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cn = translate(word(sNa, 1))
if cn == '' | symbol('sqlVarName.cn') == 'VAR' then
cn = 'COL'kx
sqlVarName.cn = 1
return cn
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
sqlHandleRCSqlCode:
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
/*???lse if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then*/
else if (sqlCode <> 0 | sqlWarn.0^==' ') & pos('w',ggRetOk)<1 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlDisconnect
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' ,
if(m.sql.conHost=='',,m.sql.conHost'/'),
|| m.sql.conSSID', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca:
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.mAlfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sql end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
if fmt == '' then
fmt = '%+Q\s'
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%-Qnxt', m.line)
end
call jClose m
fEnd = 'F.FORMAT.'fmt'%-Qend'
return res || m.fEnd
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
res = ''
st = ''
bx = m.m.pos
do forever
call sbUntil m, '"''-/'stop
if sbEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if sbLit(m, ''' "') then do
c1 = sbPrev(m)
do while \ sbStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call sbChar m, 1
if res <> '' then
return res
bx = m.m.pos
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return res
end
endProcedure jCatSqlNext
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
call outDst
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- out interface of j --------------------------------------------*/
outIni: procedure expose m.
call jIni
return
endProcedure outIni
outDst: procedure expose m.
parse arg wrt
oldOut = m.j.out
if wrt == '' then
wrt = jOpen(oNew('JSay'), '>')
m.j.out = wrt
return oldOut
endProcedure outDst
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if classInheritsOf(ggCla, class4Name('JBuf')) ,
& m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
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
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || fPlus(fmt 'nxt', m.st.sx)
end
return res || fFld(fmt 'end')
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 || '.'
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.m.area.0 = 0
call mNewArea
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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(DBX1126) cre=2012-11-26 mod=2012-11-26-16.21.41 A540769 ---
/* rexx ****************************************************************
synopsis: DBX fun args v1.4
edit macro fuer CS Nutzung von DB2 AdminTool 10.1
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr naechste AuftragsId suchen fuer praefix pr
aa: anzueigen, aw, ac entsprechendes Member editieren
n, nt neuen Auftrag erstellen (nt = test)
q subSys? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* ergaenzt scope Zeile mit infos, z.B tb -> ts
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren,
sonst werden alle expandiert
* funktioniert nicht nur in Auftrag
falls SubSys angegeben wird da gesucht sonst DBAF/DBOF
c opt? compare source gegen target
i subs nct changes in Db2Subsystem subSys importieren
subs = sub(,sub)*: Liste von Subsystemen/Umgebungen
sub: DBAF (lokal), RR2/DBOF (im PTA), RZ8(betr. Subsys)
ET, IT, PA (pta), PR (prod), pq(pta+rq2)
==> Rz/Subsys des PromotionPaths
nct: Nachtraege:
leer: noch nicht in dieses SubSys importierte
= : vom letzten import plus neue
89A : Nachtraege 8, 9 und A
v opt? version files erstellen für altes Verfahren
vc vd vj vs vt vy ec ed ej es et ey subsys? nt?
view or edit cdl, ccl jcl, srcddl, trgddl, strategY
sw rz? WSL ins RZ rz schicken und clonen, ohne rz multiclone
opt? Optionale Optionen =, -f, -=f etc. (fuer c, v, st)
= statt aktuelle source aus Db2 extrahieren
letzte extrahierte Version als Source brauchen
-f force: ignoriere QualitaetsVerletzungen
cloneWsl dbaMulti Funktionalitaet ist hier implementiert
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: v10, v72, keeptgt 0, qCheck 0, dbaCheck 0
Variabeln im Auftrag (expandiert werden $varName imd ${varName})
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
Optionen: ca, bmc, ibm
Funktionen: ia (imp+ana), ie (ia+exe), ee,ve (exejcl), ew,vw (wsl)
************************************************************************
9.11.2012 W. Keller ey und vy für view/edit strategy
*/ /* end of help
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset h
if sysvar(sysispf) = 'ACTIVE' then
call adrIsp 'Control errors return'
call jIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
do while abbrev(fun, '-')
r = substr(fun, 3)
if abbrev(fun, '-A') then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then do
m.auftrag.force = 1
end
else do
call err 'bad opt' fun 'in' wArgs
end
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'ORG.U0009.B0106.KIDI63.SKELS(dbx'
end
if 1 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ1 then
m.sysSub = DBAF
else
m.sysSub = 'noSysSubFor'm.myRz
call mapPut e, 'rexxLib', 'ORG.U0009.B0106.KIDI63.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if wordPos(fun, 'AA AC AW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if fun = 'COPYDUMMY' then
return copyDummy(args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
call memberOpt
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if wordPos(fun, 'I IA IE') > 0 then
call import fun, args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else if wordPos(fun, 'VC VD VE VJ VS VT VW VY' ,
'EC ED EE EJ ES ET EW EY') > 0 then
call viewEdit fun, args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
m.uNa = 'Marc'
else if m.uId = 'A390880' then
m.uNa = 'Martin'
else if m.uId = 'A540769' then
m.uNa = 'Walter'
else if m.uId = 'A666308' then
m.uNa = 'Frank'
else if m.uId = 'A754048' then
m.uNa = 'Alessandro'
else if m.uId = 'A790472' then
m.uNa = 'Agnes'
else if m.uId = 'A828386' then
m.uNa = 'Reni'
else
m.uNa = m.uId
m.scopeTypes = 'DB TS TB VW AL IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths */
m.iProm.1 = 'ET IT PQ PA PR'
m.iProm.2 = 'RZ1/DBAF,RZ8/DC0G RZ1/DBTF,RZ8/DD0G,RZZ/DE0G' ,
'RQ2/DBOF,RR2/DBOF RR2/DBOF RZ2/DBOF'
m.iProm.3 = 'RZ1/DBBA,RZ8/DCVG RZ1/DVTB,RZ8/DDVG,RZZ/DEVG' ,
'RQ2/DVBP,RR2/DVBP RR2/DVBP RZ2/DVBP'
m.iProm.0 = 3
return
endProcedure dbxIni
/*--- expand the import target list entered by the user
to a list or rz/subsys, with pr1Sub first and the rest sorted*/
iListExpand: procedure expose m.
parse upper arg srcList
tl = iPromExpand(translate(space(srcList, 0), '/ ', '.,'))
local = ''
remote = ''
do tx=1 to words(tl)
t1 = word(tl, tx)
if abbrev(t1, m.myRz'/') then
local = wordInsAsc(local, t1)
else
remote = wordInsAsc(remote, t1)
end
return local remote
endProcedure iListExpand
/*--- expand a target using iProm infos to a list of rz/subsys -------*/
iPromExpand: procedure expose m.
parse arg inp
if words(inp) <> 1 then do /* several words, expand each */
out = ''
do wx=1 to words(inp)
out = out iPromExpand(word(inp, wx))
end
return out
end
if pos('/', inp) > 0 then /* already expanded */
return inp
if inp == '?*?' then do /* find current promotionPath */
tg = m.scopeTrg.rz'/'m.scopeTrg.subSys
do tx=2 to m.iProm.0
if pos(tg, m.iProm.tx) > 0 then
return m.iprom.tx
end
call err 'target' tg 'not in any PromotionPath'
end
px = wordPos(inp, m.iProm.1) /* one promotion environment */
if px > 0 then
return translate(word(iPromExpand('?*?'), px), ' ', ',')
if length(inp) = 4 then /* prepend rz to subsys */
return m.myRz'/'inp
/* all subsys that match something */
alOr = iPromExpand('?*?')
all = translate(alOr, ' ', ',')
out = ''
do ax = 1 to words(all)
if pos(inp, word(all, ax)) > 0 then
if wordPos(word(all, ax), out) < 1 then
out = out word(all, ax)
end
if out \== '' then
return out
call err 'inp' inp ' not found in promotionPath' alOr
endProcedure iPromExpand
wordInsAsc: procedure expose m.
parse arg lst, wrds
do wx=1
w = word(wrds, wx)
if w == '' then
return space(lst, 1)
do rx=1 to words(lst) while w > word(lst, rx)
end
r1 = word(lst, rx)
if r1 == '' then
lst = lst w
else if w < r1 then
lst = subWord(lst, 1, rx-1) w subWord(lst, rx)
end
endProcedure wordInsAsc
charInsAsc: procedure expose m.
parse arg lst, chrs
do wx=1 to length(chrs)
c = substr(chrs, wx, 1)
do rx=1 to length(lst) while c > substr(lst, rx, 1)
end
r1 = substr(lst, rx, 1)
if rx > length(lst) then
lst = lst || c
else if c < r1 then
lst = left(lst, rx-1) || c || substr(lst, rx)
end
return lst
endProcedure wordInsAsc
/*--- batch funktionen -----------------------------------------------*/
batchOld: procedure expose m.
parse upper arg args
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
wx = 1
do forever
w1 = word(args, wx)
if w1 = '' then
return 0
if w1 = 'ADATASET' then do
m.auftrag.dataset = word(args, wx+1)
wx = wx+2
end
else if w1 = 'DO' then do
fx = wordPos('FOR', args, wx)
if fx < 1 then
call err 'DO ohne FOR in' args
cmd = subWord(args, wx+1, fx-wx-1)
do wx=fx+1
ww = word(args, wx)
if ww = '' then
leave
m.auftrag.member = ww
say 'batch do' cmd 'for' ww '...'
call work cmd
end
end
else do
if wordPos(translate(w1), 'A AC AW') > 0 then do
drop m.auftrag.member
cmd = subword(args, wx)
end
else do
m.auftrag.member = w1
cmd = subword(args, wx+1)
end
say 'batch do' cmd 'for mbr' m.auftrag.member
call work cmd
return 0
end
end
return 0
endProcedure batchOld
/*--- create the necessary dbx libries in the specified rz -----------*/
copyDummy: procedure expose m.
parse arg rz subs
call copyDummy1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.AUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CDL(DUMMY)'
/* call copyDummy1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call copyDummy1 rz, 'DSN.DBX.JCL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.MASK(DUMMY)'
/* call copyDummy1 rz, 'DSN.DBX.OVRCAT(DUMMY)' */
call copyDummy1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CADDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CAGLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) = 4 then
call copyDummy1 rz, 'DSN.DBX's1'.STRY(DUMMY)',
, 'DSN.DBXDBAF.STRY(DUMMY)'
else
call copyDummy1 rz, 'DSN.DBXMAP.'s1'(DUMMY)',
, 'DSN.DBXMAP.WKA2B(DUMMY)'
end
return 0
endProcedure copyDummy
copyDummy1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???copyDummy' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
/*--- die Konfiguration pro db2 Subsys -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, subsys
call configureRZ rz
call configureSubsys rz, subsys
return
endProcedure configureRZSub
configureSubsys: procedure expose m.
parse arg rz, subsys
call mapPut e, 'subsys', subsys
if rz = 'RZ8' then
call mapPut e, 'location', 'CHROI000'subsys
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'subsys
else
call mapPut e, 'location', 'CHSKA000'subsys
return
endProcedure configureSubsys
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG0'
rx = pos(rz'/', m.iProm.2)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.iProm.2, rx+4, 4)
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PA')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', if(rz=='RZ0', 'DSN', 'DB2@') ,
|| '.'zz'.'px'.DSNLOAD'
call mapPut e, 'capref', 'DSN.CADB2.'zz'.P0'
call mapPut e, 'caload', 'DSN.CADB2.'zz'.P0.CDBALOAD'
call mapPut e, 'cacr', DBX
if toolV \== '' then do
say 'v72 nicht mehr untertstuetzt, v10 wird benutzt'
toolV = mapGet(e, 'toolVers', 10)
toolV = ''
end
call mapPut e, 'toolVers', toolV
/* if toolV == 10 then do */
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* end
else if toolV == 72 then do
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P8'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C8'
end
else
call err 'bad toolVersion' toolV
*/ if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
else if rz = 'RR2' then do
call mapPut e, 'jobCla', 'BS0'
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz opt
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ1' then
call err 'Auftrag für RZ' rz 'muss aus RZ1 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft, 'DSN.DBA.CLON.WSL'
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if pos(make, 'CW') < 1 then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if opt = '-R' then
nop
else if rz = 'RZ1' then
call adrIsp "edit dataset('"dsnNN"')", 4
else
call writeDsn rz'/'dsnNN, m.auftrag.
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
comMask = m.libPre'.MASK('maPr'PROT)'
impMask = m.libPre'.MASK('maPr'$subsys)'
end
else do
ow = 'S100447'
comMask = m.libPre'.MASK(PROT$trgNm)'
impMask = m.libPre'.MASK($trgNm$impNm)'
end
comIgno = m.libPre'.MASK(IGNORE)'
impIgno = ''
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
zglS = '20130208 20130510 20130809 20131108 2014???? 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller pid name tel' ,
, ' comMask ' comMask ,
, ' comIgno ' comIgno ,
, ' impMask ' impMask ,
, ' impIgno ' impIgno ,
, 'source RZ8.DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%' ,
, 'target RZ8.'if(left(auftName, 2) == 'XB', 'DCVG', 'DC0G')
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
if (m.scopeSrc.rz = m.sysRz ,
| (wordPos(m.scopeSrc.rz, 'RZ8 RZZ') > 0 & m.sysRZ = 'RZ1') ,
) & m.e.qCheck \== 0 then do
if qualityCheck(getDb2Catalog('SRC')) then
if pos('F', opts) < 1 & \ m.auftrag.force then
return
else
say 'wegen Option -f Verarbeitung',
'trotz Qualitaetsfehlern'
end
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)m.e.nachtrag
m.o.0 = 0
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.subsys, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.comMask), 1)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast left(m.e.auftrag, 7)nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast left(m.e.auftrag, 7)nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
if m.e.keepTgt then
call mapPut e, 'keepTgtV', ''
else
call mapPut e, 'keepTgtV', 'KEEPTGT,'
if m.e.tool == ca then
call caDDL o, scopeSrc, dsnGetMbr(mapGet(e, 'mask'))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeTrg.rz'.'m.scopeTrg.subSys ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat",m.e.tool"Cdl") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- find the naming convention for a rz and subsystem --------------*/
namingConv: procedure expose m.
parse arg rz, subsys, var
if rz = '.' then do
if pos('.', subSys) > 0 then
call err 'namingConv old target' subsys
if pos('/', subSys) > 0 then
parse var subsys rz '/' subsys
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(subsys)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 1 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
iral = dsnAlloc(sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)')
call writeDDBegin ir
call writeDD ir, m.o.
call writeDDend 'IR'
interpret subword(irAl, 2)
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh, nac
call analyseAuftrag
if wh = 'D' then do
if words(nac) > 1 | length(word(nac, 1)) > 3 then do
d = m.libPre'Map.'word(nac, 1)
nac = subword(nac, 2)
end
else do
d = m.libPre'.caDDL'
end
end
else if wh = 'Y' then do
if length(word(nac, 1)) == 4 then
parse var nac d nac
else
d = substr(m.imp.last, 5)
rd = m.sysRz'/'d
d = m.libPre || d'.STRY'
end
else do
if wh = 'C' then
d = 'CDL'
else if wh = 'E' then
d = 'EXEJCL'
else if wh = 'J' then
d = 'JCL'
else if wh = 'S' then
d = 'SRCDDL'
else if wh = 'T' then
d = 'TRGDDL'
else if wh = 'W' then
d = 'BMCWSL'
end
if nac = '' then
d = d'('left(m.e.auftrag,7)m.e.nachtrag')'
else
d = d'('left(m.e.auftrag,7)right(strip(nac), 1)')'
if fun == 'E' then
call adrIsp "edit dataset('"d"')", 4
else
call adrIsp "view dataset('"d"')", 4
return
endProcedure viewEdit
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzSubSysList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
if ^ m.nacImp then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck == 0 then nop
else if m.e.tool \== 'IBM' then
say 'dbaCheck for' m.e.tool 'not implemented'
else do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
call configureRz m.sysRz
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
call mapPut e, 'fun', strip('import'fun fu2 left(rzSubSysList, 30))
a7 = left(m.e.auftrag, 7)
call mapPut e, 'jobName', 'Y'a7
m.e.impMasks = ''
m.jOut.0 = 0
m.jOut.toRZ.0 = 0
m.jOut.send.0 = 0
call setIf jOut
call setIf jOut'.TORZ'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = iListExpand(rzSubSysList, 0)
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' subsys
if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if m.e.tool = 'CA' then
nachAll = right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelSchub, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs/*'.V'mapGet(e,'toolVers')*/
else
call mapPut e, 'change',m.e.auftrag || m.imp.seq'_'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rz
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', a7 || right(nachAll, 1)
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureSubsys r, subsys
if m.e.tool == 'CA' then
call caImport jOut, fun, r, subsys, nachAll,
, mapExp(e, m.e.impMask), mapExp(e, m.e.comIgno)
else
call ibmImport jOut, fun, r, subsys, nachAll,
, mapExp(e, m.e.impMask), mapExp(e, m.e.comIgno)
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fun)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
if m.e.tool <> ibm & m.jOut.ifLine \== '' then do
call mAdd jOut, '// IF ABEND OR NOT (',
, '// ' m.jOut.ifLine ') THEN',
, '//PERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
end
call writeSub jOut
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
if m.o.send.0 \== 0 & m.sysRz \== m.myRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.c1 \== 1 then do
m.cdlSent.c1 = 1
if sAft == '' then do
call mapPut e, 'toRz', m.myRz
call mapPut e, 'cdl', dsnSetMbr(c1)
call addIf o
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIf o, 'end'
call setIf o, 'CP'm.myRz
end
end
if m.o.toRZ.0 == 0 then do
end
else if m.sysRz == m.myRz then do
call addIf o
call mAddSt o, o'.TORZ'
call addIf o, 'end'
m.o.ifLine = m.o.toRz.ifLine
end
else do
call addIf o
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call mAddSt o, o'.TORZ'
call mAdd o, la
call addIf o, 'end'
call setIf o, 'SUB'm.myRz
end
m.o.toRZ.0 = 0
call setIf jOut'.TORZ'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
say 'ibmImport' o',fun='fun', rz='rz', dbSys='dbSys,
|| ',nachAll='nachAll', mask='msk', ignore='ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o.send, c1
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TORZ', nachAll
return
endProcedure ibmImport
caImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
say 'caImport' o',fun='fun', rz='rz', dbSys='dbSys,
|| ',nachAll='nachAll', mask='msk', ignore='ign
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
mskMbr = dsnGetMbr(msk)
call mapPut e, 'ddlin', m.libPre'.CADDL('mapGet(e, 'mbrNac')')'
call mapPut e, 'comIgnoMbr', dsnGetMbr(ign)
call mapPut e, 'impMaskMbr', mskMbr
if mskMbr \== '' & substr(mskMbr, 5) \== left(mskMbr, 4) then do
mapDdl = m.libPre'MAP.'mskMbr'('mapGet(e, 'mbrNac')')'
call mapPut e, 'ddlout', mapDdl
if m.caMapDdl.mapDdl \== 1 then do
m.caMapDdl.mapDdl = 1
call importMapping o, mskMbr, nachAll, mapDdl
call stepGroup o
end
call mapPut e, 'ddlin', mapDdl
call mapPut e, 'impMaskMbr', ''
end
call mAdd o'.SEND', mapGet(e, 'ddlin')
call mapPut e, 'stry', mapGet(e, 'mbrNac')
call mapPut e, 'bpid', m.libPre'.CASTRAT-'mapGet(e, 'mbrNac')
call addIf o'.TORZ'
call mapExpAll e, o'.TORZ', skelStem('CImp')
call addIf o'.TORZ', 'end'
call setIf o'.TORZ', 'AUTO'
if mskMbr == '' then
m.o.toRZ.0 = m.o.toRZ.0 -2 /* die maskZeilen entfernen */
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
call addIf o'.TORZ'
call mapExpAll e, o'.TORZ', skelStem('CAna')
if mskMbr \== '' then
call caGlbChg o'.TORZ', mskMbr
call addIf o'.TORZ', 'end'
call setIf o'.TORZ', 'ANA', 0 4
end
if wordPos(fun, 'IE') > 0 then do /* execute step */
call addIf o'.TORZ'
call mapExpAll e, o'.TORZ', skelStem(left(m.e.tool, 1)'Exe')
ej = mapExp(e, "'${libPre}.EXEJCL($mbrNac)'")
call addIf o'.TORZ', 'end'
call setIf o'.TORZ', 'RUN'
j.1 = 'exeJcl for' m.e.auftrag 'noch nicht generiert'
call writeDsn ej, j., 1, 1
end
return
endProcedure caImport
importOld: procedure expose m.
parse upper arg fun, rzSubSysList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if words(m.targets) > 1 then
call err 'i=import mit mehreren targets muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
if ^ m.nacImp then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck == 0 then nop
else if m.e.tool \== 'IBM' then
say 'dbaCheck for' m.e.tool 'not implemented'
else do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
call readDsn m.libSkels || left(m.e.tool, m.e.tool\=='IBM')'Imp)',
, m.ic.
list = iListExpand(rzSubSysList, 0)
if list = '' then
call err 'no targets in list "'rzSubSysList'"'
impCnt = 0
call configureRz m.sysRz
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
call mapPut e, 'fun', strip('import'fu2 left(rzSubSysList, 30))
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
m.e.impMasks = ''
fu2 = fun fu2
m.jOut.0 = 0
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call stepGroup 1
j0 = m.jOut.0
rz = '?'
do lx = 1
r1 = word(list, lx)
parse var r1 r '/' subsys
if r <> rz | subsys = '' then do
if impCnt <> 0 then do
if rz <> m.sysRz then do
if symbol('m.sCdl.0') \== 'VAR' then do
call readDsn m.libSkels'sCdl)', m.sCdl.
call readDsn m.libSkels'subRz)', m.subRz.
end
if m.impMbrs == '' then
call err 'int no impMbrs'
call mapPut e, 'mbrNac',
, left(m.e.auftrag, 7)left(m.impMbrs, 1)
call mapPut e, 'toRz', m.myRz
call mapExpAll e, jOut, sCdl
jy = m.jOut.0
jx = jy-1
m.jOut.0 = jx
jla = m.jOut.jy
cx = pos(')-', m.jOut.jx)
if cx < 1 | substr(m.jout.jx, cx+2) \= '' then
call err 'bad sCdl line' jx':'m.jOut.jx
m.jOut.jx = left(m.jOut.jx,cx-1) '-'
do mx=2 to length(m.impMbrs)
call mAdd jOut, left('', cx-10)',' ,
|| left(m.e.auftrag,7) ,
|| substr(m.impMbrs, mx,1) '-'
end
call mAdd jOut, left('', cx-10)') -'
call mAdd jOut, jLa
call mapExpAll e, jOut, subRz
jy = m.jOut.0
jla = m.jOut.jy
m.jOut.0 = jy-1
call mAddSt jOut, jAft
call mAdd jOut, jLa
end
end
if subsys = '' then do
if m.jout.0 > j0 then
call writeSub jOut
return
end
rz = r
if rz = m.sysRz then do
job = jOut
m.jAft.0 = 'noUse'
end
else do
job = jAft
m.jAft.0 = 0
end
m.impMbrs = ''
call configureRz rz
impCnt = 0
call mapPut e, 'fun', 'import'fu2 rz
call mapPut e, 'fu2', fun
call configureSubsys rz
end
if length(subsys) <> 4 then
call err 'ungueltiges db2SubSys' subsys 'im import' rz
call configureSubsys rz, subsys
if rz = m.sysRz then
impCnt = impCnt + importAdd(job, subsys, opt, ic, fu2)
else if m.sysRz == 'RZ1' then
impCnt = impCnt + importAdd(job, rz'/'subsys, opt, ic, fu2)
else
call err 'cannot import into' rz 'from' m.sysRz
end
endProcedure importOld
/*--- add a single import to jcl in o --------------------------------*/
importAdd: procedure expose m.
parse upper arg o, rzSubSys, opt, fun fu2
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ begin */
deltaNew = 1 /* abbrev(rzSubSys,'RZ1.'),
| (pos('.',rzSubSys) < 1 & m.sysRz = 'RZ1') */
if deltaNew then do /* neues delta merge verfahren */
inDdn = 'DCHG'
call mapPut e, 'cType', "''''T''''"
end
else do /* altes delta merge verfahren */
inDdn = 'SRCDDN2'
call mapPut e, 'cType', "''''C''''"
end
call mapPut e, 'inDdn', inDdn
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ end */
if opt ^= '' & opt ^= '=' then do
nachAll = opt
end
else if symbol('m.imp.rzSubSys.nachtrag') ^== 'VAR' then do
nachAll = m.compares
end
else do
if opt = '=' then
la = left(m.imp.rzSubSys.nachtrag, 1)
else
la = right(m.imp.rzSubSys.nachtrag, 1)
cx = pos(la, m.compares)
if cx < 1 then
call err 'nachtrag' la 'von' rzSubSys m.rzSubSys.change ,
'nicht in Compare Liste' m.compares
nachAll = substr(m.compares, cx + (opt ^= '='))
end
if nachAll = ' ' then do
say 'alle Nachtraege schon importiert fuer' rzSubSys
return 0
end
call mapPut e, 'mbrChg', left(m.e.auftrag, 7)right(nachAll, 1)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelSchub, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs/*'.V'mapGet(e,'toolVers')*/
else
call mapPut e, 'change',m.e.auftrag || m.imp.seq'_'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzSubSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.impIgno))
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call bmcVarsProf 1
if m.impMbrs = '' & m.myRz \== m.sysRz then
call mapExpAll e, o, skelStem(m.jobcard) /* Jobcards */
m.impMbrs = charInsAsc(m.impMbrs, nachAll)
if m.e.tool = 'CA' then do
return 1
endProcedure importAdd
stepGroup: procedure expose m.
parse arg f
if f == 1 then
no = 1
else
no = m.e.stepNo + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return
endProcedure stepGroup
setIf: procedure expose m.
parse arg o, stp, codes
if stp == '' then
li = ''
else do
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = stp'.RUN AND'
pr = '('
if codes == '' then
codes = 0
do cx=1 to words(codes)
li = li pr stp'.RC='word(codes,cx)
pr = 'OR'
end
li = li ')'
end
if length(li) > 53 then
call err 'if too long' li
m.o.ifLine = li
if li == '' then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt
if m.o.ifLine == '' then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else
call mAdd o, '// IF' m.o.ifLine 'THEN'
return
endProcedure addIf
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
call addIf o
ic = skelStem('Imp')
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIf o, 'end'
call setIf o, 'AUTO'
return
endProcedure ibmImportExpand
importMapping: procedure expose m.
parse arg o, msk, nachAll, mapDdl
oldRz = m.myRz
oldSub= mapGet(e, 'subsys')
if m.myRz \== m.sysRz then
call configureRZSub m.sysRz, m.sysSub
say '???adding impMbr' msk
call addIf o
mStry = left(m.e.auftrag, 7)'#'
call mapPut e, 'mStry', mStry
interpret subword(dsnAlloc(mapDdl '::F'), 2)
call mAdd o,'//****** importMasking' mask 'begin ???????'
call mapExpAll e, o, skelStem('CMAP')
call mapPut e, 'ddlout', mapDdl
call caGlbChg o, mapGet(e, 'impMaskMbr')
call mAdd o,'// ENDIF'
call mAdd o,'//****** importMasking' mask 'end ???????'
call addIf o, 'end'
call setIf o, 'MANA', 0 4
if m.myRz \== oldRz then
call configureRZSub oldRz, oldSub
return
endProcedure importMapping
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'CADDL') ,
|| '('left(m.e.auftrag, 7) || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.subSys = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.subSys = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
m.nacImp = 0
m.e.impMask = ''
m.e.comMask = ''
m.e.tool = 'IBM'
m.e.keepTgt = 1
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER COMMASK COMIGNO IMPMASK IMPIGNO' ,
'KEEPTGT DBACHECK QCHECK V72 V10 CA BMC IBM'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = m.auftrag.lx
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
w2 = translate(word(li, 2))
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if wordPos(w1, 'V72 V10') > 0 then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'subSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.subsys = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.subsys
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . subsys nachAll chg .
subsys = translate(subsys, '/', '.')
if pos('/', subsys) < 1 then
subsys = 'RZ1/'subsys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = subSys
m.imp.subSys.nachtrag = nachAll
if wordPos(subSys, allImpSubs) < 1 then do
allImpSubs = allImpSubs subSys
m.imp.subSys.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.subSys.nachTop , m.nachtragChars) then
m.imp.subSys.nachTop = substr(nachAll, nx, 1)
end
m.imp.subSys.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.e.keepTgt = m.e.keepTgt == 1
/* nachtrae durchgehen und kumulieren */
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 0 & abbrev(m.scopeSrc.subSys, 'DQ0') then
call configureRz , '915 P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop subsys
say ' scope ' m.scp.0 m.scp.subsys ,
' target ' m.scopeTrg.0 m.scopeTrg.subsys
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call configureSubsys m.scopeTrg.rz, m.scopeTrg.subsys
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
if m.sysRz = m.scp.rz then
call sqlOConnect m.scp.subSys
else
call sqlOConnect m.scp.rz'/'m.scp.subSys
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sql2St substr(sql, 8), st
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
qualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.log <> 'Y' then
call mAdd o, n 'not logged'
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
spezialFall: procedure expose m.
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-'left(m.st.sx, 78)
end
return
endProcedure spezialFall
/*--- mask handling initialise ---------------------------------------*/
maskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask a whole scope --------------------------------------------*/
maskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
testMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
maskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
mask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
maskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
maskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
maskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg subSys
subs2 = ''
rf = 1
isConn = 0
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
if \ isConn & subsys == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if subSys = '' then
subSys = if(subs2 == '', m.pr1Sub, subs2)
subsys = translate(subsys, '/', '.')
call sqlConnect subSys
subsys = translate(subsys, m.mAlfLC, m.mAlfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu subSys) < 70 then
neu = left(neu, 68 - length(subSys)) '*'subSys
else if length(neu subSys) < 80 then
neu = neu '*'subSys
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end || min(strip(creator) ||'.'|| strip(name))",
"from sysibm.systables" ,
"where type = 'T' and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName"
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case when type = 'T' then 'tb'",
"when type = 'V' then 'vw'",
"when type = 'A' then 'al'",
"else '?' || type end,",
"strip(creator) || '.' || strip(name),",
"case when type = 'A' then 'for '",
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type =" quote(left(ty, 1), "'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where seqNo=1 and schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = left(m.e.auftrag, 7) || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.caddl($mbrNac)'))
call caDD1 o, scp, GlbChg
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg
call mapPut e, 'user', userid()
call mapExpAll e, o, skelStem('CCOM')
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type == 'DB' then
call caEx o, 'DATABASE' '=' m.sn.name, 'db'
else if m.sn.type == 'IX' then
call caEx o, 'INDEX' m.sn.qual m.sn.name, 'i'
else if m.sn.type == 'TS' then
call caEx o, 'TABLESPACE' m.sn.qual m.sn.name, 'ts'
else if m.sn.type == 'VW' then
call caEx o, 'VIEW' m.sn.qual m.sn.name, 'v'
else
call err 'implement type' m.sn.type 'for ca'
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".caGlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/*--- add explode options depending on object type -------------------*/
caEx: procedure expose m.
parse arg o, oLine, ty
call mAdd o, '' oLine
call caE1 o, ty, 'e TABLESPACE db'
call caE1 o, ty, 'e TABLE db ts'
call caE1 o, ty, 'e INDEX db ts t'
call caE1 o, ty, 'e VIEW db ts t v'
call caE1 o, ty, 'e SYNONYM db ts t v'
call caE1 o, ty, 'e TRIGGER db ts t v'
call caE1 o, ty, 'e MQTB_T db ts t v'
call caE1 o, ty, 'e MQTB_I db ts t v'
call caE1 o, ty, 'e MQTB_V db ts t v'
call caE1 o, ty, 'e MQTB_S db ts t v'
call caE1 o, ty, 'e MQVW_VW db ts t v'
call caE1 o, ty, 'e MQVW_I db ts t v'
call caE1 o, ty, 'e MQVW_V db ts t v'
call caE1 o, ty, 'e MQVW_S db ts t v'
call caE1 o, ty, 'i MQVW_VW i'
return
endProcedure caEx
caE1: procedure expose m.
parse arg o, ty, v1 v2 types
if v1 == 'e' then
e = 'EXPLODE'
else if v1 == 'i' then
e = 'IMPLODE'
else
call err 'bad explode' v1 'in caE1('o',' ty',' v1 v2 types')'
if wordPos(ty, types) > 0 then
call mAdd o, ' 'left(e, 11) v2
return
endProcedure caE1
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.subsys \== m.scopeTrg.subsys then
call err 'bmc compare on different subsystems not implemented'
call configureSubsys m.scopeSrc.rz, m.scopeSrc.subsys
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlOConnect m.scp.subSys
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
m.sqlO.cursors = left('', 200)
call jIni
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, m.sql.cx.type
if m.sql.cx.type \== '' then
m.sql.cx.type = class4Name(m.sql.cx.type)
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
return sqlCsmUpdate(cx, src, retOk)
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
return sqlCsmUpdate(cx, src, retOk)
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlOConnect: procedure expose m.
parse arg sys, retCon
call sqlOIni
return sqlConnect(sys, retCon)
endProcedure sqlOConnect
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
ggRet = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
ggRet = ggRet w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if sub == '' then
call sqlOConnect
else if sub \== m.sql.connected then
call sqlConnect sub
return sqlStmts(src, strip(ggRet), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
's' ==> spufi formatting (window 72) otherwise linebreak */
sqlStmts: procedure expose m.
parse arg src, ggRet, opt
dlm = ';'
isStr = oStrOrObj(src, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call sbSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
w1 = translate(word(s1, 1))
if w1 == 'TERMINATOR' then do
dlm = strip(substr(m.s.val, 12))
if length(dlm) \== 1 then
call scanErr s, 'bad terminator' dlm 'in' strip(m.s.val)
iterate
end
call out sqlStmt(s1, ggRet, opt)
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = 'sqlCode' r1
if wordPos(m.sql.cx.fun, 'DELETE INSERT UPDATE') > 0 then
res = res',' m.sql.cx.updateCount 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
else if m.sql.cx.updateCount\=='' & m.sql.cx.updateCount\=0 then
res = res',' m.sql.cx.updateCount 'rows updated'
aa = strip(src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = m.rdr.rowCount 'rows fetched'
end
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
call sqlFreeCursor cx
return res':' aa
endProceduire sqlStmt
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
if pos('-', ggRet) < 1 & fun = 'DROP' then
ggRet = -204 ggRet
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, ggRet, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.mAlfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%+Q\s'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec('describe cursor :crN into :M.SQL.'crs'.D')
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 49)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlo.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlo.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%+Q v, f ')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = mNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conSSID
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay 'sqlCode +100 row not found\nstmt =' ggSqlStmt
else
call errSay sqlMsg(sqlCA2rx(sqlCa)), ,'w'
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
f = m.sql.cx.type
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
if f \== '' then do
f = f'.FLDS'
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
/*--- initialize sqlRx (belongs to sqlQ, but currently only one|) ----*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlCAMsg = 0
m.sqlSuMsg = 2
call sqlPushRetOk
m.sql.ini = 1
m.sql.conType = ''
return 0
endProcedure sqlIni
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlOIni
hst = ''
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
cTy = 'Rx'
end
if m.sql.conType == cTy & m.sqlHost==hst & m.sqlConSSID == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.conSSID = sys
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conhost = ''
m.sql.conSSID = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
if retOk == '' then
retOk = 100 m.sqlRetOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, ggRet)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, ggRet)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, ggRet)
end
res = sqlExec(src, ggRet)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | fun == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = sqlGetCursor()
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = sqlGetCursor()
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2One
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
s = ''
src = inp2str(src, '%+Q\s')
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
return sqlExec('prepare s'cx s 'from :src', ggRetOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cn = translate(word(sNa, 1))
if cn == '' | symbol('sqlVarName.cn') == 'VAR' then
cn = 'COL'kx
sqlVarName.cn = 1
return cn
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
sqlHandleRCSqlCode:
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
/*???lse if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then*/
else if (sqlCode <> 0 | sqlWarn.0^==' ') & pos('w',ggRetOk)<1 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlDisconnect
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' ,
if(m.sql.conHost=='',,m.sql.conHost'/'),
|| m.sql.conSSID', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca:
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.mAlfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sql end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
if fmt == '' then
fmt = '%+Q\s'
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%-Qnxt', m.line)
end
call jClose m
fEnd = 'F.FORMAT.'fmt'%-Qend'
return res || m.fEnd
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
res = ''
st = ''
bx = m.m.pos
do forever
call sbUntil m, '"''-/'stop
if sbEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if sbLit(m, ''' "') then do
c1 = sbPrev(m)
do while \ sbStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call sbChar m, 1
if res <> '' then
return res
bx = m.m.pos
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return res
end
endProcedure jCatSqlNext
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
call outDst
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- out interface of j --------------------------------------------*/
outIni: procedure expose m.
call jIni
return
endProcedure outIni
outDst: procedure expose m.
parse arg wrt
oldOut = m.j.out
if wrt == '' then
wrt = jOpen(oNew('JSay'), '>')
m.j.out = wrt
return oldOut
endProcedure outDst
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if classInheritsOf(ggCla, class4Name('JBuf')) ,
& m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
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
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || fPlus(fmt 'nxt', m.st.sx)
end
return res || fFld(fmt 'end')
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 || '.'
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.m.area.0 = 0
call mNewArea
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 out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
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.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':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(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- 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
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- 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 errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
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
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/