zOs/war/u1611280
}¢--- A540769.WK.JAVA(FEINS) cre=2016-11-06 mod=2016-11-06-14.56.35 A540769 ----
dfs
}¢--- A540769.WK.JCL(DB2BICO) cre=2007-01-08 mod=2016-10-24-13.42.26 A540769 ---
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//* LIBRARY(PCL.U0000.P0.RZ4AKT.PERM.@008.DBR) -
//* LIBRARY('CMN.DIV.P0.QMSW.#000010.DBR') -
//* LIBRARY('PCL.U0000.P0.RZ4AKT.PERM.@008.DBR') -
//*
//E01 EXEC PGM=IKJEFT01,DYNAMNBR=30
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD *
DSN S(DE0G)
REBIND PACKAGE ( DSNREXX_500.DSNREXX.(V11R1) ) -
ENABLE ( CICS ) CICS(LOESCHEN) -
PLANMGMT(OFF)
//
REBIND PACKAGE ( DSNREXX_500.DSNREXX.(V11R1) ) -
ENABLE ( CICS ) CICS(LOESCHEN) -
PLANMGMT(EXTENDED)
//
REBIND PACKAGE ( DSNREXX_500.DSNREXX.(V11R1) ) -
SWITCH ( PREVIOUS )
//
BIND PACKAGE(DSNREXX_500) -
COPY(DSNREXCS.DSNREXX)-
COPYVER(V11R1) -
OWNER(S100447) -
EXPLAIN(Y) ACTION(ADD)
//
ENABLE ( CICS ) CICS(LOESCHEN,ABER,SUBITO)
ENABLE ( * )
ENABLE ( CICS ) CICS(LOESCHEN, ABER, SUBITO)
ENABLE ( DB2CALL)
ENABLE ( CICS ) CICS(DBADMIN,ISTAM,LOESCHEN)
//
FREE PACKAGE ( DSNREXX_500.DSNREXX.(V11R1) )
//
}¢--- A540769.WK.JCL(DB2LOAD) cre=2006-05-22 mod=2016-10-20-09.56.12 A540769 ---
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//S1 EXEC PGM=DSNUTILB,PARM='DP4G,A540769L.LOAD' 00020001
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//DDI1 DD *
//SYSIN DD *
LOAD INDDN DDI1 LOG NO RESUME YES
INTO TABLE QTXCRX.TEW55A
}¢--- A540769.WK.JCL(DB2MODRE) cre=2016-10-20 mod=2016-10-20-09.54.07 A540769 ---
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//S1 EXEC PGM=DSNUTILB,PARM='DP4G,A540769L.LOAD' 00020001
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF LST INCLUDE TABLESPACE QZ01A1P.A045A PARTLEVEL 0
MODIFY RECOVERY LIST LST DELETE DATE 20160926
}¢--- A540769.WK.JCL(IDCAM2) cre=2016-11-22 mod=2016-11-22-09.04.10 A540769 ----
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//TSO EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//SYSTSIN DD *
rename 'dsn.db2.panel' 'dsn.db2.panels'
DEFINE ALIAS (NAME('dsn.db2.panel' ) -
REL ('dsn.db2.panels' ) )
//SYSTSIF DD *
rename 'A540769.tmp.ali1' 'A540769.tmp.aliRen'
DEFINE ALIAS (NAME('A540769.tmp.ali1' ) -
REL ('A540769.tmp.aliRen' ) )
//SYSINA DD *
DEFINE CLUSTER ( NAME(DBZF.DGDB9998.A600A028.P00006.VSAM) -
VOL(B1N145))
//SYSINB DD *
DEFINE NONVSAM ( NAME(DBZF.DGDB9998.A600A028.P00006.CDZUPS6K) -
DEVT(3390) VOL(B1N145))
DEFINE NONVSAM ( NAME(DBZF.DGDB9998.A600A028.P00006.NONVSA3 ) -
DEVT(3390) VOL(B1N145))
//SYSINC DD *
DELETE ( -
DBZF.DGDB9998.A600A028.P00006.CDZUPS6K -
DBZF.DGDB9998.A600A028.P00006.NONVSA3 -
) NOSCRATCH
IF MAXCC > 8 THEN SET MAXCC = 99
//SYSIND DD *
DELETE ( -
DBZF.DGDB9998.A600A028.P00006.VSAM.DATA
)
//SYSINE DD *
DELETE ( -
DSN.TMP.A540769.TRACE3) CLUSTER
DEFINE CLUSTER( -
SAME(DSN.TMP.A540769.TRACE3) -
MB(050) SHR(2,3) LINEAR)
//*
}¢--- A540769.WK.JCL(USSCOPYH) cre=2016-11-25 mod=2016-11-25-12.52.18 A540769 ---
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//CPUSSTO EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSIN DD DUMMY
//SYSUT2 DD PATH='/u/a540769/fromZos.html',PATHDISP=(KEEP,DELETE),
// FILEDATA=TEXT,
// PATHOPTS=(OWRONLY,OCREAT),PATHMODE=(SIRWXU,SIRWXG,SIROTH)
//SYSUT1 DD *
<html>
<body>
<h1>titel</h1>
mit freundlichen Grüssen von A540769.WK.JCL(USSCOPYH) -
siehe \\omvss42.itzrh.ska.com\home
</body>
</html>
}¢--- A540769.WK.JCL(WI104) cre=2016-12-30 mod=2016-12-30-07.40.01 A540769 -----
//A540769Z 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=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD DISP=SH,DSN=A540769.WK.SQL(WI104)
}¢--- A540769.WK.JCL(WST) cre=2016-06-06 mod=2016-11-10-13.29.22 A540769 -------
//A540769Z JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,
// SCHENV=DB2,CLASS=M1
//JOBLIB DD DISP=SHR,DSN=PCL.U0000.P0.RZ4AKT.PERM.@008.LLB
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
//* PARM='%WST t all all'
// PARM='%WST t alLong alLong'
//* PARM='%WST t all timeTot all timeTot'
//* PARM='%WST t dsn2 sqlCsm sqlWsh sqlws2'
//SYSPROC DD DSN=A540769.WK.REXX,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//*OUT DD DSN=A540769.WK.TEXW(EINS),DISP=SHR
}¢--- A540769.WK.REXX($) cre=2016-11-25 mod=2016-11-26-07.26.59 A540769 --------
alter table oa1p.TQZ121DDLRULE
alter table "oa1p " . " TQZ121DDLRUcc "
-- table oa1p.TQZ121DDLRUCC
.abc DSN PARM(DP4G)
-- generating rebinds in DP4G at 07:24:17 26/11/16 for A540769
-- for 0 tablespace, 2 table, 0 view, 0 index, 0 alias, 0 synonym
-- table OA1P.TQZ121DDLRULE
-- table oa1p. TQZ121DDLRUcc.ABC
REBIND PACKAGE(OA1P.FQZ121GETSTD.(V1))
--bef7=0 sysE=0 vivo=RSYY con=1A35E6C805D18E16 tst=2016-11-22-13.42.09.972025
-- generating rebinds in DP4G at 07:24:32 26/11/16 for A540769
-- for 0 tablespace, 2 table, 0 view, 0 index, 0 alias, 0 synonym
-- table OA1P.TQZ121DDLRULE
-- table oa1p. TQZ121DDLRUcc.ABC
-- 1 rebinds in lines 15 - 19 deleted
--bef7=0 sysE=0 vivo=RSYY con=1A35E6C805D18E16 tst=2016-11-22-13.42.09.972025
-- generating rebinds in DP4G at 07:24:56 26/11/16 for A540769
-- for 0 tablespace, 2 table, 0 view, 0 index, 0 alias, 0 synonym
-- table OA1P.TQZ121DDLRULE
-- table oa1p. TQZ121DDLRUcc.ABC
-- 1 rebinds in lines 21 - 25 deleted
-- generating rebinds in DP4G at 07:25:08 26/11/16 for A540769
-- for 0 tablespace, 2 table, 0 view, 0 index, 0 alias, 0 synonym
-- table OA1P.TQZ121DDLRULE
-- table oa1p. TQZ121DDLRUcc.ABC
.CALL DSN PARM(DP4G)
.DATA
REBIND PACKAGE(OA1P.FQZ121GETSTD.(V1))
.ENDDATA
.SYNC 1000003 'rebind FQZ121GETSTD'
}¢--- A540769.WK.REXX(ABUB) cre=2014-01-13 mod=2016-11-04-10.22.32 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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
m.sql.cx.sqlClosed = 1
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 do
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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:
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 ******************************************************/
/* 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
call iiIni
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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy 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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(ANAPOST) cre=2012-12-04 mod=2016-11-12-22.19.13 A540769 ---
/* rexx anaPost -------------------------------------------------------
walter 12.11.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:
12.11.16 Walter remove set sqlid/schema, no rebind if sysEntries <> 0
----------------------*/ /* end of help -------------------------------
24. 8.16 Walter global temporary tables
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 12.11.16 arg='space(mArg, 1)
if mArg <> '' then
exit workMain(mArg)
if 1 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 0 then do
call workFun 'ANA', 'DBOF', wf010340 ,
, 'A540769.TMP.TEXT(wf01034A)' ,
, 'A540769.TMP.TEXT(wf01034P)' ,
, 0 , 'A540769.TMP.TEXT(wf01034O)' ,
, 'A540769.TMP.TEXT(wf01034Q)'
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, 'e'
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 = ''
cSet = 0
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 == 'SET' & m.aa.ax.obj <> '' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
if cSet = 0 then
call genAdd1 oo, 5, "set current sqlid = 'S100447';"
cSet = cSet + 1
laTo = m.aa.ax.to
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' | m.p.doRb == 'sysEnt>0' 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 sysEntries <> 0 then 'sysEnt>0'",
"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 sysEnt>0'
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 v == 'SET' then
call anaSet m, s
else if wordPos(v, 'COMMENT COMMIT LABEL RENAME') > 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 SET statments -------------------------------------*/
anaSet: procedure expose m.
parse arg m, s
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'id expected after set'
if m.s.val == 'SCHEMA' | m.s.val == 'CURRENT_SCHEMA' then
m.m.obj = 'SCHEMA'
else if m.s.val == 'CURRENT' then
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'id expected after set current'
else if m.s.val == 'SQLID' | m.s.val == 'SCHEMA' then
m.m.obj = m.s.val
return
endProcedure anaSet
/*--- 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...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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 || 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 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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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
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 ***************************************************/
/* 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(BINDDB) cre=2014-04-02 mod=2016-11-07-15.10.51 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 1 then
exit errHelp('no input')
parse upper value 'PGM abc4567890 f -t jobTest' ,
'alab 01.01.14 rzy yavmur 839695E39692F0F1' ,
'pgm2 839695E39692F0F2' with mFun mRest
parse upper value 'e A540769.WK.REXX(BINDteb3)' with mFun mRest
parse upper value 's A540769.WK.TEXV(bindRes3) 8' with mFun mRest
parse upper value 's WOK.U0000.P0.RZ4AKT.HK.RQ2DBR.RES.D151211',
with mFun mRest
end
if mFun == 'B' then
call callCmn 'PGM' argExp(1, mRest)
else if mFun == 'D' then
call callCmn 'DBP' argExp(0, mRest)
else if mFun == 'E' then do
/* call dsnAlloc 'dd(dbrmLib) CMN.DIV.P0.DB2J.#000223.DBR' */
call dsnAlloc 'dd(dbrmLib) A540769.WK.DBRM'
call callCmn 'EXE' mRest
call tsoFree dbrmLib
end
else if mFun == 'R' then
call callCmn 'REBIND' argExp(1, mRest)
else if mFun == 'S' then do
if words(mRest) == 1 then
mRest = mRest 0
call callCmn 'RES' mRest
end
else
call callCmn mFun mRest
exit 0
callCmn: procedure expose m.
parse arg fun rest
fr = ''
if wordPos(fun, 'DBP PGM REBIND') > 0 then do
showDD = 'BIND'
call dsnAlloc 'dd(bind) new ::f'
end
else if fun = 'EXE' then do
parse var rest in out err
if in = '' then
return errHelp('i}no input for Exe:' fun rest)
fr = fr word(dsnAlloc( 'dd(bind)' in), 2)
if out = '' then
call dsnAlloc 'dd(bindRes) new ::v2500'
else
call dsnAlloc 'dd(bindRes)' out '::v2500'
if err = '' then
call dsnAlloc 'dd(bindErr) new ::f'
else
call dsnAlloc 'dd(bindErr)' err '::f'
showDD = 'BINDRES BINDERR'
end
else if fun = 'RES' then do
if words(rest) <> 2 then
return errHelp('i}bad input for Res:' fun rest)
fr = fr word(dsnAlloc( 'dd(bindRes)' word(rest, 1)), 2)
rest = word(rest, 2)
showDD = ''
end
else
return errHelp('i}bad fun' fun 'in:' fun rest)
if m.inlineCMN then
res = cmnWork(fun, rest)
else
res = bindcmn(fun rest)
doShow = showDD \== '' & (abbrev(res, 'ok') | fun = 'EXE')
if \ (m.inlineCMN & doShow) then
say fun 'res =' res
call tsoFree fr
if doShow then do sx=1 to words(showDD)
dd1 = word(showDD, sx)
call adrIsp "LMINIT DATAID(lmmId) ddName("dd1") ENQ(SHRW)"
eRc = adrIsp("edit dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
end
if showDD \== '' then
call tsoFree showDD
if \ abbrev(res, 'ok') then
call err 'e}'res
else if doShow & ((eRc \== 0 & eRc \== 4) | lRc \== 0) then
call err 'e}'m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure callCmn
argExp: procedure expose m.
parse arg isLo, args
res = argEx2(isLo, args)
if \ m.inlineCMN then
if space(res, 1) <> space(args, 1) then
say 'expanding' args '==>' res
return res
endProcedure argExp
argEx2: procedure expose m.
parse arg isLo, w1 w2 rest
if appl = '' then
call err 'i}no arguments'
if isLo then
h = userid() 't' left('bindDB:'translate(m.mArg, '-',' '), 20) ,
mvsvar('symdef', 'jobname')' '
else
h = ''
i = anaInst(w1)
if i \== '' then
return h'appl' i w2 rest
i = anaInst(w2)
if i \== '' then
return h || w1 i rest
i = anaInst(date('s'))
if length(w1) == 4 then
return h || w1 i w2 rest
else
return h'appl' i w1 w2 rest
endProcedure argEx2
/* |||| copy bindCMN und adrISP ||||||||||||||||||||||||||||||||||||||*/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* REXX ----------------------------------------------------------------
bindCMN: db2 bind Interface for changeMan
synopsis: BINDCMN PGM cmPkg f1 com cmJob appl install rz (pgm conTok?)+
BINDCMN DBP appl install pgm
BINDCMN EXE
BINDCMN RES cmRes
functions:
PGM: generate program/package binds for one RZ
and archive it in tQZ043BindGen and tQZ044BindLine
DBP: generate dbp (program/package binds for all RZ)
EXE: execute generate binds and write result dataset
RES: read result dataset and update tQZ043BindGen
parameters:
appl: the cmn application (first 4 letters of cmn package)
install: installDate in format dd.mm.yyyy
pgm : the program name, one for DBP, as many as needed for bindGen
cmPkg: changeman package: char(10)
f1: 1 character changeman Function code
com: comment (changeman function, user etc.)
cmJob: name of the bind job in the target RZ
rz, dbSys: target of the promotion
pgm: program
conTok: contoken = 16 hexDigits (default 0000000000000000)
cmRes: the condition Code (0 or 8) of the changeman promote/install
io:
DD BIND: output for PGM, DBP etc, input for EXE
DD BINDRES: output for EXE, input for RES
DD BINDErr: output for EXE detailed error report
db2 tables: tQZ043BindGen, tQZ044BindLine: for PGM / RES
Achtung: bindCMN is included completely in bindDB, thus,
do all changes in bindDB and then
replace bindCMN with the appropriate part of bindDB
14.12.15: Walter handle eMsg unicode length and avoid sql error
---------------*/ /*---------------------------------------------------
24. 9.14: Walter errMsg auch fuer bindCC=4
4. 9.14: Walter exe schreibt bindErr (Detail Fehler Meldungen)
dd bindRes und tQZ043BindGen enthalten errMsg
res benötigt und tQZ043BindGen enthält cmRes
9. 7.14: Walter doRes nicht nur erste 100 Zeilen lesen
10. 6.14: Walter added cmnFun and conToken. Removed bindGen with pgm=''
22. 4.14: Walter added exe, adapted res etc..
4. 4.14: Walter enhanced bindDB, update cmJob in bindRes
2. 4.14: Walter avoid 1/0 for compiler, remove duplicate copies
29. 3.14: Walter bindGen, bindRes und History Tables
14. 3.14: Walter neuer HLQ und installDate Formate
19.11.13: Walter neu copies
4.10.13: Walter neu
---------------------------------------------------------------------*/
m.sql_dbSys = ''
call errReset "hi", "call errReset 'hi'" ,
"; call errSay 'f}'ggTxt; call errCleanup",
"; if m.sql_dbSys <> '' then do" ,
"; call sqlUpdate ,'rollback'; call sqlDisconnect; end" ,
"; exit 'error' ggTxt"
parse upper arg fun rest
/*%SYSDATE */
/*%SYSTIME */
say "BINDCMN Vers:" SYSDATE"/"SYSTIME "/Function:" FUN "/" REST
if wordPos(fun, 'DBP PGM EXE RES') < 1 then
return errHelp('i}bad fun' fun 'in:' fun rest)
exit cmnWork(fun, rest)
cmnWork: procedure expose m.
parse arg fun, rest
if pos('?', fun rest) > 0 | fun = '' then
exit help()
if fun <> 'EXE' then
call sqlConnect 'DP4G'
if fun == 'PGM' then
res = doPGM(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'REBIND' then
res = doRebind(ana7(subword(rest, 1, 7)), subWord(rest, 8))
else if fun == 'DBP' then
res = doDBP(anaAI(rest))
else if fun == 'EXE' then
res = doExe()
else if fun == 'RES' then
res = doRes(rest)
else
return errHelp('i}bad args:' fun rest)
if m.sql_dbSys <> '' then
call sqlDisconnect
return res
endProcedure cmnWork
exit 0
anaAI: procedure expose m.
parse arg appl inst rest
if appl = '' then
call err 'i}no arguments'
if rest = '' then
call err 'i}no program:' appl inst rest
i = anaInst(inst)
if i == '' then
call err 'i}bad installDate' inst 'in:' appl inst rest
if length(appl) <> 4 then
call err 'i}bad appl' appl 'in:' appl inst rest
return appl i rest
endProcedure anaAI
ana7: procedure expose m.
parse arg args
parse arg cmPkg f1 com cmJob appl inst rz rest
if length(cmPkg) > 10 then
call err 'i}bad cmPkg' cmPkg 'args:' args
if length(f1) <> 1 then
call err 'i}bad cmFun' f1 'args:' args
if length(com) > 20 then
call err 'i}bad com' com 'args:' args
if length(cmJob) > 20 then
call err 'i}bad cmJob' cmJob 'args:' args
i = word(anaAI(appl inst 'x'), 2)
if length(rz) <> 3 | \ abbrev(rz, 'R') then
call err 'i}bad rz' rz 'args:' args
return cmPkg f1 com cmJob appl i rz rest
endProcedure ana6
anaInst: procedure expose m.
parse arg inst
today = translate('78.56.1234', date('s'), '12345678')
i0 = translate(inst, '000000000', '123456789')
if i0 == '00000000' then
return translate('78.56.1234', inst, '12345678')
else if i0 == '0000' then
return translate('34.12', inst, '1234')substr(today, 6)
else if i0 == '00.00' then
return inst || substr(today, 6)
else if i0 == '00.00.00' then
return left(inst,6)substr(today, 7, 2)right(inst, 2)
else if i0 == '00.00.0000' then
return inst
else
return ''
endProcedure anaInst
doPGM: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindRz" ,
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doPGM
doRebind: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
call insPgmGen cmPkg f1 com cmJob appl inst rz, pgms
res = selWriUpd( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040Rebind",
"where rz = '"rz"'")
call sqlCommit
call sqlDisConnect
return res
endProcedure doRebind
doDBP: procedure expose m.
parse arg appl inst pgms
call insPgm appl inst, pgms
res = selWri( ,
"select dbSys, pgm , stmt, row_number() over" ,
"(partition by pgm order by" ,
"appl, pgm, install, rdlSeq, cqSeq, ovSeq) seq",
"from oa1p.vQZ040BindDBP")
call sqlCommit
call sqlDisConnect
return res
endProcedure doDBP
doExe: procedure expose m.
call tsoOpen 'BIND', 'R'
call readDD 'BIND', i., '*'
call tsoClose 'BIND'
ox = 0
ex = 0
ey = ex
ccMax = 0
ccId = 0
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
str = 'b'
do ix = 1 to i.0 /* each line */
/* concat one command */
li = strip(doExeComm(i.ix), str)
if iCmd = '' then
ey = ex + 2
else
ey = ey + 1
e.ey = li
if right(li, 1) == '-' then do
iCmd = iCmd || left(li, length(li)-1)
str = 't'
iterate
end
else if right(li, 1) == '+' then do
iCmd = iCmd || left(li, length(li)-1)
str = 'b'
iterate
end
else do
iCmd = iCmd || li
end
/* we have one command in iCmd */
str = 'b' /* for next cmd */
if iCmd = '' then
iterate
if iFirst == '' then do /* dsn command */
iFirst = strip(iCmd)
iCmd = ''
iterate /* look next bind */
end
if translate(iCmd) = 'END' then do /* end of program */
ox = ox+1 /* result for program */
o.ox = 'res' ccId,
'job' strip(jobInfo(name))'#'strip(jobInfo(num)) ,
'id' m.doExe.iId 'pgm' m.doExe.iPgm
if ccId > 0 then
if length(eM) <= 2000 then
o.ox = o.ox 'err' eM
else
o.ox = o.ox 'err' left(eM, 1997)'...'
ccMax = max(ccMax, ccId)
ccId = 0 /* reset variables */
iFirst = ''
iCmd = ''
eM = ''
m.doExe.iId = '?'
m.doExe.iPgm = '?'
iterate
end
/* we got one bind in iCmd */
do while queued() > 0 to /* clear input queue */
parse pull pOld
say 'err pulled:' pOld
ccMax = max(99, ccMax)
end
say iFirst '=>' space(iCmd, 1) /* execute dsn bind end */
queue iCmd
queue 'end'
cc = adrTso(iFirst, '*')
do tx=1 to m.tso_trap.0 /* say output of bind */
say m.tso_trap.tx
end
cc2 = cc
if cc < 0 | \ datatype(cc, 'n') then
cc2 = 999
if cc2 > 0 then do
ez = ex+1 /* write whole command to err */
e.ez = iFirst
ex = ey
end
eM = doExeMsg(eM, cc2 ccId, iFirst, iCmd)
ccId = max(ccId, cc2)
say e.actMsg
iCmd = '' /* end one bind */
end /* each line */
if iCmd \== '' | iFirst \== '' then
call err 'fileEnd but iCmd='iCmd', iFirst='iFirst
if ccId \== 0 | eM \== '' then
call err 'fileEnd but ccId='ccId', eM='eM
if ex = 0 then do
ex = ex + 1
e.ex = 'ccMax =' ccMax
end
call tsoOpen 'BINDRES', 'W'
call writeDD 'BINDRES', 'o.', ox
call tsoClose 'bindRes'
call tsoOpen 'BINDErr', 'W'
call writeDD 'BINDErr', 'e.', ex
call tsoClose 'BINDErr'
if ccMax <= 4 then
return 'ok ccMax' ccMax 'for exe'
else
return 'err ccMax' ccMax 'for exe'
endProcedure doExe
doExeMsg: procedure expose m. e. ex
parse arg eM, cc2 ccId, iFirst, iCmd
m0 = sysvar(sysNode)
cx = pos('(', iFirst)
if cx > 0 & right(iFirst, 1) == ')' then
m0 = m0'/'substr(iFirst, cx+1, length(iFirst)-cx-1)
else
m0 = m0'/'iFirst
uCmd = translate(iCmd)
cx = pos('PACKAGE(', uCmd)
cy = pos('MEMBER(', uCmd)
if cx > 0 & cy > 0 then do
col = word(substr(iCmd, cx+8), 1)
if right(col, 1) == ')' then
col = left(col, length(col)-1)
mbr = word(substr(iCmd, cy+7), 1)
if right(mbr, 1) == ')' then
mbr = left(mbr, length(mbr)-1)
sCmd = left(iCmd, min(cx, cy)-1) col'.'mbr
end
else do
sCmd = iCmd
end
if length(m0) > 30 then
actM = left(m0, 27)'...' sCmd
else
actM = m0 sCmd
if cc2 > 4 | cc2 < 0 then
e.actMsg = strip(left('error cc='cc2 actM, 80))
else if cc2 > 0 then
e.actMsg = strip(left('warning cc='cc2 actM, 80))
else do
e.actMsg = strip(left('ok cc='cc2 actM, 80))
ex = ex + 1
e.ex = e.actMsg
return eM
end
actM = ''
do tx=1 to m.tso_trap.0
t1 = m.tso_trap.tx
ex = ex + 1
e.ex = left(t1, 80)
if wordPos(word(t1, 1), 'DSNX200I') > 0 then
iterate
j = space(t1, 1)
if j == 'USING CMNBATCH AUTHORITY' ,
| j == 'PLAN=(NOT APPLICABLE)' ,
| j == 'DBRM='m.doExe.iPgm then
iterate
cx = pos('=', j)
if cx > 1 then
if pos('='left(j, cx),
, '=SQLSTATE=CSECT NAME=RDS CODE=') > 0 then
iterate
actM = actM' 'j
end
if eM == '' then
return m0':' actM';'
else if cc2 > ccId then
return m0':' actM';' eM
else
return eM m0':' actM';'
endProcedure doExeMsg
doExeComm: procedure expose m.
parse arg src
res = ''
cy = -1
do forever
cx = pos('/*', src, cy+2)
if cx < 1 then
return res || substr(src, cy+2)
res = res || substr(src, cy+2, cx-cy-2)
cy = pos('*/', src, cx+2)
if cy < 1 then
com = strip(substr(src, cx+2))
else
com = strip(substr(src, cx+2, cy-cx-2))
say '/*' com
w1 = word(com, 1)
if w1 == 'beginRzPgm' then
m.doExe.iPgm = strip(subword(com, 2))
else if w1 == 'id' then
m.doExe.iId = strip(subword(com, 2))
if cy < 1 then
return res
end
endProcedure doExeComm
doRes: procedure expose m.
parse arg cmRes
if ^ (cmRes == 0 | cmRes == 8) then
call err 'cmRes bad cmRes =' cmRes
call readDD bindRes, i., '*'
call tsoClose bindRes
maxCC = 0
if i.0 < 1 then
return err('e}no lines in dd bindRes')
do ix=1 to i.0
parse var i.ix cRes res cJob jobPP cId id cFu pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
if length cFu <> 1 & pos('@', cFu) > 0 then do
cFu = ' '
parse var i.ix cRes res cJob jobPP cId id pkgTst ,
cPgm rzDbsys appIns pgm cEr eMsg
end
parse var pkgTst pkg '@' tst
parse var rzDbSys rz '/' dbSys
parse var appIns appl '@' install
if cRes \== 'res' then
return err('e}res (not' cRes') expected in res' ix':'i.ix)
if cJob \== 'job' then
return err('e}job (not' cJob') expected in res' ix':'i.ix)
if cId \== 'id' then
return err('e}id (not' cId') expected in res' ix':'i.ix)
if cPgm \== 'pgm' then
return err('e}pgm (not' cPgm') expected in res' ix':'i.ix)
if pgm = '' then
return err('e}pgm missing in res' ix':'i.ix)
if length(cFu) <> 1 then
return err('e}bad cmFun' cFu ix':'i.ix)
if cEr \== '' & cEr \== 'err' then
return err('e}bad errFlag='cEr eMsg ix':'i.ix)
/* no error: we will see missing/spurios errormsg in table
if (cEr == '') <> (res == 0) then
return err('e}res='res 'but err='cEr eMsg ix':'i.ix)
if cEr \== '' & eMsg == '' then ??? till now empty for rc=4
return err('e}no error message in res' ix':'i.ix) */
if length(res) > 4 | res == '' then
call err 'i}bad res =' res 'in' arg(1) res
if res >= 0 & datatype(res, 'n') then
maxCC = max(res, maxCC)
else
maxCC = max(999, maxCC)
eMsg = translate(eMsg, ',', 'FF'x) /* token separator */
if length(eMsg) > 2000 then
eMsg = left(eMsg, 1997)'...'
asUni = "as varchar(6000) ccsid unicode"
call sqlUpdate 3, "update oa1p.tQZ043BindGen" ,
"set result = '"res"', cmJob = '"jobPP"'" ,
", resTst = current timestamp" ,
", cmRes =" cmRes ,
", errMsg = case when length(cast("quote(eMsg, "'") ,
asUni ")) <= 2000 then" quote(eMsg,"'") ,
"else" quote(left(eMsg, 1500)'...', "'") "end" ,
"where genId =" id ,
"and cmPkg = '"pkg"' and genTst = '"tst"'" ,
"and appl = '"appl"' and install = '"install"'" ,
"and rz = '"rz"' and dbSys = '"dbSys"'"
if m.sql.3.updateCount <> 1 then
return err(m.sql.3.updateCount "rows updated for res."ix ,
i.ix)
end
call sqlCommit
call sqlDisConnect
return 'ok,' i.0 'results maxCC' maxCC
endProcedure doRes
/*--- insert pgms into table bindPgm --------------------------------*/
insPgm: procedure expose m.
parse arg appl inst, pgms
do px = 1 to checkPgms(pgms)
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install)",
"values ('"appl"', '"m.pid.px"', '"inst"')"
end
return
endProcedure insPgm
/*--- insert pgms into table bindPgm and bindGen --------------------*/
insPgmGen: procedure expose m.
parse arg cmPkg f1 com cmJob appl inst rz, pgms
genSql = "select genTst, pgm, genid from final table(" ,
"insert into oa1p.tQZ043BindGen" ,
"(cmPkg, cmFun, com, cmJob, appl, install, rz, dbSys" ,
",pgm, conTok, genTst)" ,
"values('"cmPkg"', '"f1"', '"com"', '"cmJob"', '"appl"'",
", '"inst"', '"rz"', '?'"
do px = 1 to checkPgms(pgms)
if px=1 then
m.genTst = sql2One(genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"'" ,
", max(current timestamp, value((select max(genTst)" ,
"from oa1p.tqz043BindGen)+ 1e-6 seconds" ,
", current timestamp))))" , bindGen)
else
call sql2One genSql ,
", '"m.pid.px"', x'"m.pid.px.conTok"', '"m.genTst"'))",
, bindGen
if m.genTst \== m.bindGen.genTst then
call err 'genTst mismatch' m.genTst '<>' m.bindGen.genTst
m.pid.px.genid = m.bindGen.genId
m.pid.px.genTst = m.bindGen.genTst
call sqlUpdate , "insert into oa1p.tQZ040BindPgm" ,
"(appl, pgm, install, id, info)",
"values ('"appl"', '"m.pid.px"', '"inst"'," m.pid.px.genId ,
", 'id" m.pid.px.genId f1 cmPkg"@"m.pid.px.genTst"')"
end
return
endProcedure insPgmGen
checkPgms: procedure expose m.
parse upper arg pgms
px = 0
wx=1
wZ = words(pgms)
do while wx <= wZ
px = px+1
p1 = word(pgms, wx)
wx = wx + 1
if length(p1) < 4 | length(p1) > 8 then
call err 'i}bad program' p1 'in' pgms
if symbol('m.p2x.p1') == 'VAR' then
call err 'i}duplicate program' p1 'in' pgms
m.pid.px = p1
m.p2x.p1 = px
c1 = word(pgms, wx)
if length(c1) = 16 & verify(c1, '00123456789ABCDEF')=0 then do
m.pid.px.conTok = c1
wx = wx+1
end
else
m.pid.px.conTok = left('', 16, 0)
end
if px < 1 then
call err 'i}no programs'
m.pid.0 = px
return m.pid.0
endProcedure checkPgms
/*--- select and insert bind statements,
check programs, update dbSys in bindGen
write to dd bind ---------------------------------------------*/
selWriUpd: procedure expose m.
parse arg qry
call sql2St ,
"select dbSys, pgm, line from final table(" ,
"insert into oa1p.tQZ044BindLine (genId, seq, line)",
"include(dbSys char(4), pgm char(8))",
"select p.Id, b.seq, b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"left join oa1p.tQZ040BindPgm p" ,
"on b.pgm = p.pgm )",
"order by pgm, seq", bb, ":m.dst.dbSys, :m.dst.pgm, :m.dst"
return checkPgmUpdWri(bb, 1)
endProcedure selWriUpd
/*--- select bind statements, check programs,
write to dd bind ---------------------------------------------*/
selWri: procedure expose m.
parse arg qry
call sql2St ,
"select b.stmt" ,
", value(b.dbSys,'"m.sqlNull"')" ,
", value(b.pgm ,'"m.sqlNull"')" ,
"from ("qry") b" ,
"order by pgm, seq", bb, ":m.dst, :m.dst.dbSys, :m.dst.pgm"
return checkPgmUpdWri(bb, 0)
endProcedure selWriUpd
/*--- check programs, if updDbSys then update dbSys in bindGen
write to dd bind ---------------- ----------------------------*/
checkPgmUpdWri: procedure expose m.
parse arg bb, updDbSys
ds = ''
do sx=1 to m.bb.0
p1 = strip(m.bb.sx.pgm)
if p1 = m.sqlNull | m.bb.sx.dbSys = m.sqlNull then
iterate
if symbol('m.p2x.p1') \== 'VAR' then
call err 'fetched pgm' p1 'not in list'
if symbol('p2d.p1') \== 'VAR' then do
px = m.p2x.p1
p2d.p1 = strip(m.bb.sx.dbSys)
if wordPos(p2d.p1, ds) < 1 then
ds = ds p2d.p1
if updDbSys then do
call sqlUpdate 7, "update oa1p.tQZ043BindGen" ,
"set dbSys = '"p2d.p1"'",
"where genId =" m.pid.px.genId ,
"and genTst = '"m.pid.px.genTst"'" ,
"and pgm = '"p1"'"
if m.sql.7.updateCount <> 1 then
call err 'set dbSys updateCount' ,
m.sql.7.updateCount '<> 1'
end
end
else if p2d.p1 \== strip(m.bb.sx.dbSys) then do
if updDbSys then
call err 'pgm p1 multi dbSys' p2d.p1 m.bb.sx.dbSys
end
end
mis = ''
do px=1 to m.pid.0
p1 = m.pid.px
if symbol('p2d.p1') \== 'VAR' then
mis = mis p1
end
if mis \== '' then
call err 'w}nothing generated for programs' mis
call tsoOpen 'BIND', 'W'
call writeDD 'BIND', 'M.bb.'
call tsoClose 'BIND', 'W'
return 'ok' m.pid.0 'programs' m.bb.0 'lines'
endProcedure checkPgmUpdWri
/* rexx */
jobInfo: procedure expose m.
parse arg w
v = 'JOBINFO_'w
if symbol('m.v') == 'VAR' then
return m.v
if m.jobInfo_Ini == 1 then
call err 'no jobInfo for' w
m.jobInfo_Ini = 1
call #jInfo_jobInfo
call mPut 'JOBINFO_TYPE', #JINFO_JTYPE
call mPut 'JOBINFO_NUM' , #JINFO_JNUM
call mPut 'JOBINFO_NAME', #JINFO_JNAME
return jobInfo(w)
endProcedure jobInfo
/*
** >>Jobinfo
*/
#JINFO_JOBINFO:
#JINFO@cvt = storage(10,4) /* FLCCVT-PSA data area */
#JINFO@cvtsname = storage(d2x(c2d(#JINFO@cvt) + 340),8) /* CVTSNAME */
#JINFO@tcbp = storage(d2x(c2d(#JINFO@cvt)),4) /* CVTTCBP */
#JINFO@tcb = storage(d2x(c2d(#JINFO@tcbp)+4),4)
#JINFO@tiot = STORAGE(D2X(C2D(#JINFO@tcb)+12),4) /* Get TIOT address */
#JINFO@jscb = STORAGE(D2X(C2D(#JINFO@tcb)+180),4)
#JINFO@ssib = STORAGE(D2X(C2D(#JINFO@jscb)+316),4)
#JINFO@jinfo = STORAGE(D2X(C2D(#JINFO@tiot)),24)
#JINFO_JTYPE = STORAGE(D2X(C2D(#JINFO@ssib)+12),3)
#JINFO_JNUM = strip(storage(D2X(C2D(#JINFO@ssib)+15),5),l,0)
#JINFO_JNAME = substr(#JINFO@jinfo,1,8)
#JINFO_JPROC = substr(#JINFO@jinfo,9,8)
#JINFO_JPROCSTEP = substr(#JINFO@jinfo,17,8)
#JINFO_CVTSNAME = #JINFO@cvtsname /* system name */
drop #JINFO@cvt #JINFO@tcbp #JINFO@tcb #JINFO@tiot #JINFO@jscb
drop #JINFO@ssib #JINFO@jinfo #JINFO@cvtsname
return
#JINFO_DROP:
DROP #JINFO_JTYPE #JINFO_JNUM #JINFO_JNAME #JINFO_JPROC #JINFO_JPROCSTEP
return
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%,%c ')
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
m.sql.cx.fetchCode = cd
st = 'SQL.'cx'.COL'
call sqlRemVars st
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
return
end
m.sql.cx.fetchVars = ''
vrs = ''
sNu = ''
if abbrev(src, '?') then do
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end
end
else if src <> '' then do kx=1 to words(src)
cn = word(src, kx)
call sqlRexxAddVar cn, 0, m.sql.cx.d.kx.sqlType // 2
end
else do kx=1 to m.sql.cx.d.sqlD
call sqlRexxAddVar m.sql.cx.d.kx.sqlName, 1 ,
, m.sql.cx.d.kx.sqlType // 2
end
m.sql.cx.fetchVars = substr(vrs, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
sqlCol2kx: procedure expose m.
parse arg cx, nm
if symbol('M.SQL.CX.COL.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col.nm
if m.sql.cx.col.kx \== nm then
call err 'sqlCol2kx' nm '==>' kx 'but' m.sql.cx.col.kx
return kx
endProcedure sqlCol2kx
sqlRemVars: procedure expose m.
parse arg st
if symbol('m.st.0') == 'VAR' then do
do sx=1 to m.st.0
nm = m.st.sx
drop m.st.nm m.st.sx
end
end
m.st.0 = 0
return
endProcedure sqlRemVars
sqlAddVar: procedure expose m.
parse arg st, sNa, nicify
sx = m.st.0 + 1
if 1 | nicify then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('m.st.sNa') == 'VAR' then
sNa = 'COL'sx
end
m.st.0 = sx
m.st.sx = sNa
m.st.sNa = sx
return sNa
endProcedure sqlAddVar
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 1 then do
hahi = m.sql_HaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql_HaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet == '*' then
return m.tso_rc
else if wordPos(m.tso_rc, ggRet) > 0 then
return m.tso_rc
else
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call saySt(splitNl(err, 'tsoAlloc rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call saySt(splitNl(err, 'rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csmNull begin **************************************************
pseudo csm Modul, to avoid missing modules error from rexx compiler
***********************************************************************/
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
call err 'csmAlloc not copied into this rexx'
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
call err 'csmLikeAtts not copied into this rexx'
/* copy csmNull end ***************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
call adrTso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(CAX) cre=2012-11-14 mod=2016-11-28-10.13.34 A540769 ------
/* rexx ----------------------------------------------------------------
Credit Suisse line commands in RCQ Caspar 28.11.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
28.11.16 walter : sqlExImm --> sqlUpdate
------------------------------*/ /*--- end of help ---------------------
23.11.16 caspar : RX Erweiterung subtotale / templ#s / neue copies
15. 7.16 walter : mit caxIdKeys. neuen copies etc.
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')
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 sqlIni
call scanReadIni
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 do
scx = 7
l = substr(zScreenI, scx*zScreenW+1, zScreenW)
end
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
li = strip(li, 't')
if li = '' | wordPos(ut2lc(word(li,1)),
, 'dbsys: path:') > 0 then
leave
if \ abbrev(li, ' ') & ly > ty+1 then
call err 'bad cycle line' ly 'ty)='ty li
cx = cx + 1
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')
if pos(m.sqlnull, substr(li,vx)) > 0 then
iterate
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
call out ' * valid='m.pkl.px.valid ,
'op='m.pkl.px.operative ,
'sysEntries='m.pkl.px.sysEntries ,
'used='m.pkl.px.lastUsed ,
'bind='m.pkl.px.bindTime
if m.pkl.px.sysentries <> 0 then
call out ' * package gelöscht',
strip(m.pkl.px.collid) ,
|| '.'strip(m.pkl.px.name) ,
|| '.('strip(m.pkl.px.version)')'
else if m.pkl.px.type = '' | m.pkl.px.type = 'F'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 sqlUpdate 7, "set current sqlid = 'S100447'"
if sql2One("select name from sysibm.sysDatabase" ,
"where name = '"uxDb"'", 'uxDB', '') ,
\== uxDb then do
call sqlUpdate 7, "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 sqlUpdate 7, "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 = sqlUpdate(7, "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 sqlUpdate 7, "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 sqlUpdate 7, "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#S)"
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',
'sysentries valid operative lastUsed bindTime'
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 space')
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 ft, cx, 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.
parse arg ft, cx, roll ':' sums
/* jBuffer i mit SQL resultat füllen */
i = in2Buf(sqlQuery2Rdr(cx))
/* neuer buffer o */
o = jOpen(jBuf(), '>')
/* inputwerte roll&sums auf uppercase (weil sie UC von db2 kommen*/
upper roll
upper sums
t0 = oNew(objClass(m.i.buf.1))
/* neues objekt am anfang der späteren resultliste einfügen */
call jWrite o, t0
tr = oNew(objClass(m.i.buf.1))
/* columns die weder in ROLL noch SUMS vorkommen mit +++ */
ff = oFldD(tr)
do fx=1 to m.ff.0
f1 = t0 || m.ff.fx
m.f1 = m.sqlNull
end
/* als "Totalzeile" markieren */
m.t0.dbName = 'total'
/* initialisieren der totalwerte für jede "sum" */
do sx=1 to words(sums)
s1 = word(sums, sx)
m.t0.s1 = 0 /* summen total */
m.tr.s1 = 0 /* summen rollups */
end
/* loop über buffer um totale zu summieren */
/* i.buf.0 ist anzahl resultate */
do rx=1 to m.i.buf.0
r = m.i.buf.rx /* aus zeile #rx eigenes objekt machen */
/* neue rollupzeile nötig? */
do sx=1 to words(roll)
s1 = word(roll, sx) /* welche columns werden geprüft? */
if m.tr.s1 ^= m.r.s1 then do
newRollup = 1 /* braucht neue rollup zeile */
end
end
/* abhandeln wenn neuer rollup (1. oder wechsel ) entdeckt */
if newRollup then do
tr = oNew(objClass(m.i.buf.1)) /* zeile einfügen, hier damit */
do fx=1 to m.ff.0
f1 = tr || m.ff.fx
m.f1 = m.sqlNull
end
call jWrite o,tr /* sie oberhalb der rows ist */
do sx=1 to words(sums) /* summen init */
s1 = word(sums, sx)
m.tr.s1 = 0
end
do sx=1 to words(roll) /* titel setzen */
s1 = word(roll, sx)
m.tr.s1 = m.r.s1
end
newRollup = 0 /* done */
end /* end newrollup */
call jWrite o, r /* row in output einfügen */
do sx=1 to words(sums) /* summen aufaddieren */
s1 = word(sums, sx)
if datatype(m.r.s1, 'n') then do
m.t0.s1 = m.t0.s1 + m.r.s1 /* total */
m.tr.s1 = m.tr.s1 + m.r.s1 /* rollup */
end
end
end
call jClose o /* output buffer schliessen */
/* format aus sqlda lesen */
call sqlFTabComplete ft, cx, 1, 1
/* ganze tabelle (o) ausgeben, ft =format */
call fTab ft, o
return m
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.2
interfaces: 1.11.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 -----------------------------------------------------------
1.11.16 walter: JRWLazy.jWriteSt wStem zuweisen, do in sqlUpdate entfernt
*********/ /*** end of help *******************************************
27.10.16 walter: nur 1 system in rq2, jTalkRdr, mark sqlClosed
21.10.16 walter: set current packageSet / path ... ohne immediate
7.10.16 walter: fix redirection Hook mit only < >, fTst
30. 9.16 walter: blkSize fix fuer csmAlloc, csmAppc mit timeout
8. 9.16 walter: redirection hook
6. 9.16 walter: dsnCopy supports different recFM and lRecL
avoid csm errors: mbrList dsn on Sequential,
lrecl < 272 without blksize on rmtOut
12. 8.16 walter: f recursive %( %, %), fTst B,I,Y,Z / comp table deimp
if, else, proc etc. erlaub nl, * Kommentare für % und ^
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 truncat.
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 = 'ORG.U0009.B0106.MLEM43.EXEC'
m.myWsh = 'WST'
m.myVers = 'v62e 1.11.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.pipeCnt = (out \== '') * 2
if m.wsh.pipeCnt == 2 then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
if isEdit then
call wshEditEnd wsh
do m.wsh.pipeCnt
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'wsh end: pipe.0='m.pipe.0
else if m.err_cleanup <> '\?' | m.tso_ddAll <> '' then
call err 'wsh end: still err cleanups'
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if sysVar(sysNode) = 'RZ0' then
return
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 = '*'
call wshIni
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 wshHookComp( ,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 ***************************************/
/* 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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 = 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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
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 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 ************************************************/
/--- 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 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
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 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 ************************************/
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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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 sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
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"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- 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 */
call csmAppc 'csmASql', , , 4
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
**********************************************************************/
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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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:
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 ******************************************************/
/* 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
call iiIni
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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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.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
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(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(DBARB) cre=2011-09-20 mod=2016-11-26-07.51.32 A540769 ----
/* rexx ****************************************************************
synopsis: DBARB (-(a¨n¨i¨t)+)? subsys?
version vom 25.11.2016
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 *************************************************************
25.11.2016 no rebind if sysEntries <> 0 (even without -n|)
************* end of help */ /****************************************
31.08.2015 do not fail when removing bind triggers
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
cLoe = 0
/* fetch each package and write rebind */
do while sqlFetchInto(1,
, ':coll, :name, :vers, :type, :info, :bef7, :sysE')
cnt = cnt + 1
if bef7 == 0 & sysE == 0 then
new = new + 1
else if sysE <> 0 then do
cLoe = cLoe + 1
iterate
end
else if pos('N', m.opt) > 0 then
iterate
coll = strip(coll)
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 ' --bef7='bef7 'sysE='sysE info
end
call sqlClose 1
tx = 'total' cnt 'packages thereof' cLoe 'to be freeed'
if pos('N', m.opt) > 0 then
say 'rebind' new 'new of' tx
else
say 'rebind' (cnt-cLoe) 'including' new 'new of' tx
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)",
", sysEntries sysE",
'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 qu '.' nm
m.qual = "'"strip(qu)"'"
m.ident = "'"strip(nm)"'"
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
if adrEdit('line_after .zl = (line)', 0 4) <> 0 then
if \ abbrev(strip(line), '--') then
say 'truncation of' 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(DBX) cre=2015-11-16 mod=2016-11-23-14.09.47 A540769 ------
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.3
21.11.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.11.2016 Walter lmm -> mbrList in auftragNext
*/ /* end of help
21.11.2016 Stephan neues ddlcheck und Anapost mit exception handling
23. 6.2016 Walter dropAll und fix fuer DDLONLY (aber CA ...)
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
***********************************************************************/
/* Konstanten ----------------------------------------------------*/
CONST_PROFILE = 1 ;
/* if userid() = 'A586114' then CONST_PROFILE = 2 */
if CONST_PROFILE = 1 then do /* PROD Konfiguration */
m.debug = 0
m.editMacro = 0
m.editProc = 0
m.aTb = 'OA1P.tAdm70A1'
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.rexxLib = 'DSN.DB2.EXEC'
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
m.libSpezial = m.libPre'.SPEZIAL'
end
if CONST_PROFILE = 2 then do /* TEST Konfiguration */
m.debug = 0
m.editMacro = 0
m.editProc = 0
m.aTb = 'OA1P.tAdm70A1'
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.rexxLib = 'DSN.DBXAPP.V33.SRC.EXEC'
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DBXAPP.V33.SRC.SKELS(dbx'
m.libSpezial = m.libPre'.SPEZIAL'
end
/* dbx.main() ----------------------------------------------------*/
call errReset hi
call sqlIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
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', m.rexxLib
/* Ersetzt durch Konfigurations Profile *************************
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
lx = mbrList(ml, dsnSetMbr(m.na.nx, pre'*'))
say left(m.ml.1, 8) '-' left(m.ml.lx, 8)right(m.ml.0, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if m.ml.lx >> max then
max = m.ml.lx
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"'", 100
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, 'r'
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))
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 == 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, 'r'
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'", 100
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'nicht in der AuftragsTable' 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 RZZ RR2') > 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 VP5 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 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
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, 'r'
else
call sqlConnect m.scp.rz'/'m.scp.dbSy, 'c'
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, 0 , 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 do
dbSy = substr(dbSy, 5)
call sqlConnect dbSy, 'r'
end
else do
call sqlConnect dbSy, 'c'
end
dbSy = ut2lc(dbSy)
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
rd = sqlRdr(sql 'order by 2', 'FT FN FI')
call jOpen rd, '<'
do cx=0 while jRead(rd)
d = m.rd
call mAdd o, lefPad(m.d.ft, 3) lefPad(m.d.fn, 30) m.d.fi
end
call jClose rd
if cx = 0 then
call mAdd o, lefPad(ty, 3) lefPad(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
/*--- 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 *************************/
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, 'r'
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, 'r'
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 = '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
call iiIni
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 dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy 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 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 ******************************************************/
/* 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
**********************************************************************/
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 sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
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"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- 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 */
call csmAppc 'csmASql', , , 4
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 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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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 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 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 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 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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(DREP) cre=2013-01-22 mod=2016-11-24-14.33.34 A540769 -----
/* rexx ***************************************************************
dRep: distribute rc Query user defined reports
synopsis: dRep fun dbSy
fun : function
a: delete all and load the KIDI63 standart reports
d: delete all
i: Insert the kidi63 reports. Only the new ones
o: overwrite existing and nonExisting ones with kidi63 standards
n: no update and don't ask again
u: update kidi63 standart reports, if a new release
?: this help
dbSy: list of db2Systems (group Name, e.g. DBAF) or * for all
history
24.11.16 Walter: handle additional column in V19
*******************/ /* end of help ***********************************
1. 9.15 Walter: automatischer update ohne nachfragen
18. 6.13 Walter: sqlDisconnect vor return wenn kein update3
19. 4.13 Walter: Fragen angepasst, Errorhandling ohne FATAL
16. 4.13 Walter: Funktion D aktiviert
. 2.13 Walter: neu
**********************************************************************/
parse upper arg fun allDb
if fun == '' then
if sysVar('sysISPF') = 'ACTIVE' then
if adrEdit('macro (mArg) PROCESS', '*') == 0 then
parse upper var mArg fun allDb
if pos('?', fun allDb) > 0 then
return help()
if length(fun) <> 1 | pos(fun, 'ADINOU') < 1 then
call errHelp 'bad fun' fun 'in dRep' fun allDb
if allDb == '*' then do
call rzInfo
rz = sysVar(sysnode)
allDb = m.rzInfo.rz.dbSys
end
if allDb = '' then
call err 'i}no db2System in dRep' fun allDb
cr = userid()
call debug 'dRep fun='fun 'user='cr 'dbSys='allDb
m.tb = "PTI.PTRCQ_SAVED_RPTS"
do dx=1 to words(allDB)
dbSy = word(allDb, dx)
if length(dbSY) <> 4 then
call err 'i}bad db2System' dbSy 'in dRep' fun allDb
call sqlConnect dbSy
if fun = 'U' then do
fun = needUpdate(fun, cr)
if fun == '' then do
call sqlDisconnect
return
end
end
say dbSy 'replacing saved reports'
call dRep fun, cr
call sqlCommit
call sqlDisconnect
end
exit
needUpdate: procedure expose m.
parse arg fun, cr
sq1 = "select colname from" m.tb ,
"where type = '??' and sub_type = '??'"
m.kVers = sql2One(sq1 "and userid = 'KIDI63'", , '-')
if m.kVers == '-' then
call err 'no report KIDI63.??.?? please install first'
m.cVers = sql2One(sq1 "and userid = '"cr"'", , '-')
if m.cVers == m.kVers then do
call debug 'already current version' m.cVers
return ''
end
return 'A' /* do not ask anymore .........*/
address tso 'clear'
say 'DBA Team recommends Credit Suisse user defined reports:'
say 'o = overwrite all reports with CS standards (recommended)'
say 'a = delete all and load the CS standard reports'
say 'i = Insert the CS reports. Only the new ones'
say 'u = update CS standard reports, if a new release'
say 'd = delete all'
say 'n = no update and don''t ask again'
say '- = end without change'
parse upper pull ant
a1 = left(strip(ant), 1)
if pos(a1, 'ADINO') > 0 then
return a1
say 'keine Mutationen, manuelle Mutation mit tso dRep'
return ''
endProcedure needUpdate
dRep: procedure expose m.
parse arg fun, cr
if fun = 'O' then do
call sqlUpdate 3, "delete from" m.tb "c" ,
"where userid = '"cr"' and exists (",
"select 1 from" m.tb "k" ,
"where userid = 'KIDI63'",
"and c.type = k.type and c.sub_type = k.sub_type",
")", 100
say 'deleted' m.sql.3.updateCount
end
if fun == 'A' | fun == 'D' then do
call sqlUpdate 3, "delete from" m.tb "c" ,
"where userid = '"cr"'" , 100
say 'deleted' m.sql.3.updateCount
end
/* find column names of table, v19 has one more| */
parse upper var m.tb tCr '.' tNm
cols = sql2one("with r (l, n) AS (",
"select varchar('', 1000), 0 from sysibm.sysDummyU",
"union all select l || case when name = 'USERID'" ,
"then '' else ', ' || strip(name) end, n+1" ,
"from r, sysibm.sysColumns",
"where tbCreator = '"tCr"' and tbName = '"tNm"'" ,
"and colNo = n + 1 and n < 999999" ,
") select max(l) from r")
if fun == 'A' | fun == 'O' then do
call sqlUpdate 3, "insert into" m.tb ,
"select '"cr"'"cols "from" m.tb ,
"where userid = '"KIDI63"'", 100
say 'inserted' m.sql.3.updateCount
end
if fun == 'I' | fun == 'N' then do
call sqlUpdate 3, "delete from" m.tb ,
"where userid = '"cr"' and type = '??'", 100
say 'deleted' m.sql.3.updateCount
wOnly = copies("and type = '??'", fun == 'N')
call sqlUpdate 3, "insert into" m.tb ,
"select '"cr"'" cols "from" m.tb ,
"where userid = '"KIDI63"'" wOnly "and not exists (",
"select 1 from" m.tb "c" ,
"where userid = '"cr"'",
"and c.type = k.type and c.sub_type = k.sub_type",
")", 100
say 'inserted' m.sql.3.updateCount
end
return 1
endProcedure dRep
rzInfo: procedure expose m.
m.rzInfo.rz = 'RZ0T RZ1 RZ2 RZX RZY RZZ RR2 RQ2'
m.rzInfo.rz0T.dbSys = 'DBIA DBTV'
m.rzInfo.rz1.dbSys = 'DBAF DBTF DBOC DVTB'
m.rzInfo.rz2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rr2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rQ2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rz4.dbSys = 'DBOL DP4G'
m.rzInfo.rzx.dbSys = 'DE0G DEVG DPXG DX0G'
m.rzInfo.rzy.dbSys = 'DE0G DEVG DPYG'
m.rzInfo.rzz.dbSys = 'DE0G DEVG DPZG'
return
endProcedure rzInfo
/* 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.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 -----------------------------*/
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
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 sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: 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 -------------------*/
sqlQuery: 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 sqlFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- 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' sqlFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
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 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 sqlUpdate
/*-- 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 sqlClose 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 sqlClose 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 ---------------------*/
sqlFetchVars: 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 sqlFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlFetchVars 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(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
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 ------------------------*/
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 = 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 SQL 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 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
/*--- 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 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, 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 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(ERR) cre=2016-10-26 mod=2016-10-26-09.51.12 A540769 ------
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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 ****************************************************/
}¢--- A540769.WK.REXX(F) cre=2016-10-26 mod=2016-10-26-09.51.12 A540769 --------
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"¢"pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
}¢--- A540769.WK.REXX(II) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 -------
/* 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
call iiIni
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 *************************/
}¢--- A540769.WK.REXX(J) cre=2016-11-06 mod=2016-11-06-17.04.18 A540769 --------
/* 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* copy j end ********************************************************/
}¢--- A540769.WK.REXX(PLOAD) cre=2009-12-01 mod=2016-11-17-12.06.40 A540769 ----
/* rexx ***************************************************************
remove mAtSq tbRoot
mVaAtK1
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze, fully qualified
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN, fully qualified as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
usefull with constraints, because of checkPen
else utility task grouped together for each TS
***********************************************************************
17.11.2016 W. Keller: rewrite with new copies
12. 8.2016 W. Keller: jes2 jobCard
************** end help **********************************************/
/************* rest of history ****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
7. 9.2011 W. Keller: templates fuer Utility statt jcl alloc
7. 9.2011 W. Keller: dsn <= 44 auf für maximal db, ts und parts
1.12.2009 W. Keller: inDDn nicht mehr nötig mit m.load <> ''
13.11.2009 W. Keller: orderTS Option funktioniert wieder
08.08.2008 W. Keller: orderTS Option eingefügt
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
**********************************************************************/
parse upper arg args
m.debug = 1
call errReset 'h'
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
return help()
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* Wort in '0123456789' - NOMATCH = Default */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(pLoadOpt)' /* m.mainlib=DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO*/
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS)*/
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = translate(space(translate(m.volume, ' ', ','),
, 1), ',', ' ')
if m.mgmtClas = '' then
m.mgmtClas = 'COM#A046'
m.mgmtClas = translate(strip(m.mgmtClas))
vol = copies('volume('m.volume')', m.volume <> '')
/* Wenn orderts = 1, dann erst alle copy und unloads
und erst nachher loads,
wenn SONST wegen Referential Integrity TS check pending werden
geht weder copy noch unload */
if m.orderts \= 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
call analyzePunch w vol
end
call addTableInfo
call checkOverride /* massage the analyzed input */
if m.tabTo.0 < 1 then
call err 'no table to load into'
/* generate jcl */
call jclGenStart
call jclGenCopyInput
punDsn = genSrcDsn('PUNCH')
call jclGenPunch punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---stem structure----------------------------------------------------
m.pun punchfiles
.?.tmpl templates in this punchfile
m.load load statement
.?.into each into clause in this load
m.table db2 table
---------------------------------------------------------------------*/
/*--- initialisation ------------------------------------------------*/
init: procedure expose m.
call scanReadIni
call catIni
m.pun.0 = 0
m.load.0 = 0
m.table.0 = 0
m.tabTo.0 = 0
call sqlConnect m.db2SubSys, 'e'
return
endProcedure init
/*--- cleanup at end of program and disconnect from DB2 -------------*/
finish: procedure expose m.
call sqlDisconnect
return
endProcedure finish
/*--- generate a SRC datatset for the created ploadid ---------------*/
/*--- Members are PUNCH and OPTIONS ---------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N)*/
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10) MGMTCLAS('m.mgmtClas')'
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contains variables and help ---------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTs'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
u = translate(v)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(m.u, "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call mAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx <wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ---------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
rr = sysDsn("'"dsn"'")
if rr == 'OK' then do
call readDsn dsn, 'M.LOG.' /* read dataset */
zx = m.log.0 /* Anzahl lines in dsn */
end /* für fun = 'load' */
else if rr == 'MEMBER NOT FOUND' then
zx = 0
else
call err 'sysDsn('dsn') ==>' rr/* next ploadid */
/* next ploadid reservieren */
if fun = 'nextId' then do
if zx == 0 then do
cId = 1
end
else do
id = strip(left(m.log.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = substr(id, 2) + 1
end
cId = 'N'right(cId, 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
m.log.0 = zx
/* max line dsn + 1 */
m.log.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* m.log.zx = N0192 20081112 11:29 newId */
end
else if zx = 0 then do
call err 'log empty'
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log*/
cId = m.id
do ax = 1 by 1 to zx while strip(left(m.log.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(m.log.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag,20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tSize = m.tabTo.0
call mMove 'LOG', bx, ax+tSize
/* one log line for each table */
do tx=1 to m.tabTo.0
tn = m.tabTo.tx
rx = ax + tx - 1
m.log.rx = le 'resume='m.tn.loadResume,
lefPad(m.tn.tots, 19) m.tn.toTb m.tn.parts
end
end
else do /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, 'M.LOG.' /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
endProcedure log
/*--- analyze a punchfile ---------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile --------------------*/
analyzePunch: procedure expose m.
parse arg puDsn
pp = mAdd(pun, dsn2jcl(puDsn))
m.pp.tmpl.0 = 0
m.pp.in = jBuf()
call readDsn puDsn, 'M.'m.pp.in'.BUF.'
call scanReadOpen scanReadReset(scanUtilOpt(sc), m.pp.in)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, pp)
end
else if utilNext == 'LOAD' then do
ch = mAdd(load, pp)
utilNext = analyzeLoad(sc, pp)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.sc.val
else if u == '' then
leave
end
end
call scanReadClose sc
return
endProcedure analyzePunch
/*--- analyze template ----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, pp
if 'u' = scanUtil(sc) then
return m.sc.val
else if m.sc.utilClass ^= 'n' then
call scanErr sc, 'template name expected'
na = m.sc.val
tt = mAdd(pp'.TMPL', na)
m.pp.n2tmpl.na = tt
do forever
if 'u' == scanUtil(sc) | m.sc.utilClass = '' then do
return m.sc.val
end
else if m.sc.utilClass=='n' & m.sc.utilBrackets=0 then do
parm = m.sc.val
if parm == 'DSN' then
m.tt.parm = dsn2jcl(scanUtilValue(sc))
else if wordPos(parm, 'VOLUME VOLUMES') > 0 then
m.tt.volume = translate(space(translate( ,
scanUtilValue(sc), ' ', ','), 1), ',', ' ')
else
call debug 'ignoring' parm scanUtilValue(sc)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.sc.utilClass m.sc.tok
/* if m.debug=1 - say xxxxx */
end
end
endProcedure analyzeTemplate
/*--- analyze load --------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, pp
bb = m.pp.in'.BUF'
if m.sc.val <> 'LOAD' then
call scanErr sc, 'not after load'
if scanUtil(sc) ^== 'n' & m.sc.val ^== 'DATA' then
call scanErr sc, 'load data expected'
laTo = scanPos(sc)
ld = mAdd(load)
m.ld.into.0 = 0
aa = ld
oo = ld'.ST'
m.oo.0 = 0
/* the load into syntax is too complex to analyze completly
instead, we simply remove the variable parts
attention: we assume not statistic specs in punch| */
do forever
bef = scanPos(sc)
if 'u' == scanUtil(sc) | m.sc.utilClass == '' then
leave
if m.sc.utilClass ^= 'n' | m.sc.utilBrackets ^= 0 then
iterate
opt = m.sc.val
if wordPos(opt, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then do
if opt = 'STATISTICS' then
say 'statistics not supported in Punch' ,
'manuall in jcl rausputzen'
iterate
end
call addTxt oo, bb, laTo , bef
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.sc.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if \ scanSqlQuId(scanSkip(sc)) | m.sc.val.0 \== 2 then
call scanErr sc, 'table name expected'
aa = mAdd(ld'.INTO', ld)
tb = m.sc.val
if symbol('m.table_n2.tb') \== 'VAR' then
m.table_n2.tb = mAdd(table, tb)
m.aa.into = m.table_n2.tb
oo = aa'.ST'
m.oo.0 = 0
end
else if opt == 'INDDN' then do
if \ scanSqlId(scanSkip(sc)) then
call scanErr sc, 'ddName for inDDN expected'
dd = m.sc.val
if symbol('m.pp.n2tmpl.dd') == 'VAR' then
m.aa.inDDN = m.pp.n2tmpl.dd
else if m.load = '' then
call scanErr sc, 'template not found for inDDn' dd
end
else if opt == 'REPLACE' then do
m.aa.replace = 1
end
else do
vv = scanUtilValue(sc)
m.aa.opt = vv
end
laTo = scanPos(sc)
end
call addTxt oo, bb, laTo, scanPos(sc)
return m.sc.val
endProcedure analyzeLoad
addTxt: procedure expose m.
parse arg oo, ii, fL fC, tL tC
ox = m.oo.0
l1 = overlay('', m.ii.fL, 1, fC - 1)
if fL = tL then
l1 = left(l1, tC - 1)
if l1 <> '' then do
ox = ox + 1
m.oo.ox = l1
end
do ix=fL+1 to tL-1
ox = ox + 1
m.oo.ox = m.ii.ix
end
if tL > fL & left(m.ii.tL, tC-1) <> '' then do
ox = ox + 1
m.oo.ox = left(m.ii.tL, tC-1)
end
m.oo.0 = ox
return
endProcedure addTxt
/*--- check loads and override values -------------------------------*/
checkOverride: procedure expose m.
rs = translate(m.resume)
do lx=1 to m.load.0 /* for each load */
ld = 'LOAD.'lx
if rs <> '' & symbol('m.ld.resume') == 'VAR'
then m.ld.resume = rs
do ix=1 to m.ld.into.0 /* for each into */
ii = ld'.INTO.'ix
if symbol('m.ii.part') \== 'VAR' then
m.ii.part = '*'
tt = m.ii.into
tt = m.tt.toRef
info = into m.tt 'part' m.ii.part
if wordPos(m.ii.part, m.tt.parts) > 0 then
call err m.tt.part 'already in parts' m.ld.parts ':'info
else
m.tt.parts = strip(m.tt.parts m.ii.part)
call overrideLoad ii, ld
if rs <> '' & symbol('m.ii.resume') == 'VAR'
then m.ii.resume = rs
end
end
return
endProcedure checkOverride
/*--- override or modify the load for into ii of load ld ------------*/
overrideLoad: procedure expose m.
parse arg ii, ld
if m.load <> '' then do
m.ii.load = m.load
m.ii.volume = m.volume
return
end
if symbol('m.ii.inDdn') = 'VAR' then
if symbol('m.ld.inDdn') = 'VAR' then
call err 'dupl inDdn' m.ii m.ld
else
tm = m.ii.inDdn
else if symbol('m.ld.inDdn') = 'VAR' then
tm = m.ld.inDdn
else
call err 'no inDdn' m.ii m.ld
m.ii.load = dsn2jcl(m.tm.dsn)
if symbol('m.tm.volume') == 'VAR' then
m.ii.volume = m.tm.volume
else
m.ii.volume = ''
return
endProcedure overrideLoad
/*--- select table from catalog, and join common tables -------------*/
addTableInfo: procedure expose m.
do tx=1 to m.table.0
tt = 'TABLE.'tx
m.tt.into.0 = 0
parse var m.tt crt '.' tbl
if m.owner <> '' then
crt = strip(m.owner)
call sql2One "select s.nTables," ,
"strip(t.creator) || '.' || strip(t.Name) totb," ,
"strip(t.dbName) || '.' || strip(t.tsName) toTs" ,
"from sysibm.systables t join sysibm.systablespace s" ,
"on s.dbName = t.dbName and s.name = t.tsName" ,
"where t.type = 'T' and t.name = '"tbl"'" ,
"and t.creator = '"crt"'", tt
tb = m.tt.totb
if symbol('m.table_to2.tb') == 'VAR' then do
m.tt.toRef = m.table_to2.tb
end
else do
m.table_to2.tb = tt
m.tt.toRef = tt
call mAdd tabTo, tt
m.tt.parts = ''
if m.tt.nTables <> 1 then do
say 'ts' m.tt.tots 'hat' m.tt.nTables 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
end
end
do lx=1 to m.load.0
do ix = 1 to m.load.lx.into.0
ii = 'LOAD.'lx'.INTO.'ix
tt = m.ii.into
call mAdd m.tt.toRef'.INTO', ii
end
end
return
endProcedure addTableInfo
/*--- write the generated jcl ---------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call tsoOpen dd, 'W'
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
/* if m.debug=1 - say xxxxx */
call writeDD dd, 'M.JCLCARD.'j'.'
end
call tsoClose dd
call tsoFree word(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL ----------------------------------------------*/
jclGenStart: procedure expose m.
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to m.pun.0 /* show input punch */
call jcl '1* punch ' m.pun.px
end
do tx=1 to m.tabTo.0 /* show output tables */
tt = m.tabTo.tx
call jcl '1* load ' m.tt.toTb 'in' m.tt.toTs
p = m.tt.parts
if p <> '*' then
call jcl '1* ' words(p) 'partitions' strip(p)
do ix=1 to m.tt.into.0 /* show input tables and dsns */
ii = m.tt.into.ix
i2 = m.ii.into
call jcl '1* from' lefPad(m.i2, 16) m.ii.load
end
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1* *.UNL und *.UNPU enthalten den letzten Stand' ,
'vor Load'
call jcl '1* und muessen (nach uerpruefung|)' ,
'von Hand rename''t werden'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix -----------------------------*/
jclGenCopyInput: procedure expose m.
do px=1 to m.pun.0 /* punch files */
call jcl '2* Originales Punchfile Kopieren'
call jclCopy m.pun.px m.volume, genSrcDsn('OPUNCH', px)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOA')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOA')
do tx=1 to m.tabTo.0
tt = m.tabTo.tx
do ix=1 to m.tt.into.0 /* each into */
ii = m.tt.into.ix
oLo = expDsn(m.ii.load, m.tt.toTs m.ii.part)
if m.ii.part = '*' then
nLo = expDsn(m.dsnLoadTs, m.tt.toTs m.ii.part)
else
nLo = expDsn(m.dsnLoadPa, m.tt.toTs m.ii.part)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy oLo m.volume, nLo
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ---------*/
jclGenPunch: procedure expose m.
parse arg puDsn
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', puDsn
call jcl '20SYSUT1 DD *'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS('m.mgmtClas')'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNL", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS('m.mgmtClas')'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS('m.mgmtClas')'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to m.tabTo.0
tn = m.tabTo.tx
if m.tn.into.0 = 0 then
iterate
call jclGenPunchCopyUnload tn, tx
call jclGenPunchLoad m.tn.into.1, tn
do ix=1 to m.tn.into.0
call jclGenPunchInto m.tn.into.ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn -------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
call jcl '2 LISTDEF COLI'tx
p = m.tn.parts
dbTs = m.tn.tots
if m.tn.parts = '*' then do
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
end
else do wx=1 to words(p)
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL' word(p,wx)
end
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
call jcl '2 COPYDDN (TCOPYD) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD LIST COLI'tx
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMULPA'
call jcl '2 SHRLEVEL REFERENCE'
return
/* call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE' */
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility until before first into --------------*/
jclGenPunchLoad: procedure expose m.
parse arg ii, tn
ld = m.ii
if symbol('m.ii.resume') == 'VAR' then
m.tn.loadResume = m.ii.resum
else if symbol('m.ld.resume') == 'VAR' then
m.tn.loadResume = m.ld.resume
else
m.tn.loadResume = 'NO'
if m.tn.loadResume = 'NO' then do
m.tn.loadResumeSpec = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
m.tn.loadResumeSpec = 'RESUME YES'
if symbol('m.ii.shrLevel') == 'VAR' then
sh = m.ii.shrlevel
else if symbol('m.ld.shrlevel') == 'VAR' then
sh = m.ld.shrLevel
else
sh = ''
if sh <> '' then
m.tn.loadResumeSpec = m.tn.loadResumeSpec 'SHRLEVEL' sh
end
if m.tn.parts == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' m.tn.loadResumeSpec 'LOG' m.tn.loadResume
if m.tn.loadResume == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' m.tn.loadResume
end
call jcl '3 SORTDEVT DISK'
call jcl '3 WORKDDN(TSYUTD,TSOUTD)'
call jcl '3 ERRDDN TERRD MAPDDN TMAPD'
do sx=1 to m.ld.st.0
call jcl '3' m.ld.st.sx
end
return
endProcedur jclGenPunchLoad
/*--- generate the db2 utility statements for 1 load or into --------*/
jclGenPunchInto: procedure expose m.
parse arg ii, tn
call jcl '3 INTO TABLE' m.tn.toTb
if m.ii.part <> '*' then do
call jcl '3 PART' m.ii.part
call jcl '3 ' m.tn.loadResumeSpec
call jcl '3 INDDN TMLOADPA'
end
do sx=1 to m.ii.st.0
call jcl '3' m.ii.st.sx
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility ------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys",",
|| userid()".UN.LO'"
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,' ,
|| 'DSN='dbSys'.DBAA.LISTDEF(TEMPL#S)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index --------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index --*/
genSrcDsn: procedure expose m.
parse arg mbr, lx /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in -----------------*/
expDsn: procedure expose m.
parse arg dsn, db '.' ts pa .
do forever
px = pos('&', dsn)
if px = 0 then do
if length(dsn) > 44 then
call err 'dsn too long' dsn
return dsn
end
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = db
else if k = 'TS' | k = 'SN' then
v = ts
else if k = 'PART' | k = 'PA' then
if pa <> '' & pa <> '*' then
v = right(pa, 5, 0)
else
call err 'part='pa 'and &pa. in tamplate' dsn
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- jcl to copy a sequential DS -----------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', to) > 0 then
call jcldd 2, 's', 'SYSUT2', to, toAt
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
dsn
atts: attributes ---------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, dsn vols, like liVo
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
li = jclDDClause(j, li, 'DSN='dsn2jcl(dsn))
if new then
li = jclDDClause(j, li, 'MGMTCLAS='m.mgmtclas)
if vols <> '' then
li = jclDDClause(j, li, 'VOL=SER=('vols'),UNIT=DISK')
if \ new | like = '' then do
end
else if liVo = '' then do
li = jclDDClause(j, li, 'LIKE='dsn2jcl(like))
end
else do
lRc = listDsi("'"dsn2jcl(like)"'",
"VOLUME("word(translate(live,' ', ','), 1)")")
if lRc <> 0 then
call err 'listDsi rc' lRc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove dsn
return
endProcedure jclDD
/*--- add a DS to the remove step -----------------------------------*/
jclRemove: procedure expose m.
parse arg dsn
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='dsn2jcl(dsn))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line --------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement ------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator --------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ---------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/* 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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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 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 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 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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 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 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 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 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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(SQL) cre=2016-11-11 mod=2016-11-11-09.43.24 A540769 ------
/* 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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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 ****************************************************/
}¢--- A540769.WK.REXX(SQLCODET) cre=2009-05-11 mod=2016-10-24-21.17.08 A540769 ---
/* rexx ****************************************************************
translate an sqlCode and Warnings to text
synopsis
sqlCodeT(sqlCode, sqlErrMC, warn, version, expEq
* return text for sqlCode with expanded arguments&warnings
sqlCodeT('/w', warn)
* return text for warnings
sqlCodeT '/g'
* generate rexx source for v8 and v9 messages
sqlCodeT '/t'
* issue some test translations
arguments:
sqlCode from sqlCA
sqlErrMC from sqlCA
warn '' or from sqlCA
sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',' ,
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10
expEx 1 for expand arguments as ${argumentName=argumentValue}
version: 'V8', 'V9' or '' (for default, currently V8)
***********************************************************************/
/**** History **********************************************************
01.05.08 W.Keller, KIUT 23 - neu
***********************************************************************/
call errReset h
parse arg sqlCode, sqlErrMc, warn, version, expEq
if ^ abbrev(sqlCode, '/') then
return sqlCodeText(sqlCode, sqlErrMc, warn, version, expEq)
if sqlCode = '/w' then
return sqlCodeWarn(sqlErrMc)
if sqlCode = '/g' then do
call mIni
m.pref = '~wk.texv(sqlCod'
call sqlCodeConvertV8
call sqlCodeConvertV9
call sqlCodeMerge 'V8 V9', 'VV'
end
else if sqlCode = '/t' then do
call mIni
say sqlCodeText(0)
say sqlCodeText(-152)
say sqlCodeText(-152, , , 'V7')
say sqlCodeText(-152, 'eins', 'W: WWW,WWWZW', 'V8')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei'||'ff'x||'drei')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei'||'ff'x||'drei',
||'ff'x||'vier')
end
else do
call errHelp 'bad argument sqlCode' sqlCode
end
exit
sqlCodeText: procedure expose m.
parse arg co, mc, warn, rel, expEq
if rel = '' then
rel = 'V9'
expEq = expEq = 1
st = sqlCodeT'.'rel
if symbol('m.st') <> 'VAR' then do
call sqlCodeFromSource st, 'sqlCodes', rel
if m.st = 0 then
say 'warning no sql Message for release' rel
end
cc = co+0
if symbol('m.st.co') = 'VAR' then
li = m.st.co
else
li = "<<text for sqlCode" co "not found>>"
cx = 1
px = 1
res = ''
do forever
nx = pos('${', li, cx)
if nx < 1 then
leave
ex = pos('}', li, nx)
if ex < cx then
call err 'closing } missing in' li
if ^ expEq then
res = res || substr(li, cx, nx - cx)
else
res = res || substr(li, cx, ex - cx) || '='
cx = ex+(^expEq)
if px > length(mc) then do
res = res || '<missingErrMC>'
end
else do
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res || substr(mc, px, qx-px)
px = qx + 1
end
end
res = res || substr(li, cx)
do while px <= length(mc)
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res '${extraErrMc =' substr(mc, px, qx-px)'}'
px = qx + 1
end
ww = sqlCodeWarn(warn)
if ww \= '' then
res = res '\nwarnings' ww
return strip(res)
endProcedure sqlCodeText
/*--- return the text for the passed warnings
in format 0:12345,6789A ---------------------------*/
sqlCodeWarn: procedure expose m.
parse arg warn
if warn = '' | abbrev(warn, 'SQLWARN.') then
return ''
wAll = substr(warn, 3, 5)substr(warn, 9, 5)
if substr(warn, 2, 1) ^== ':' | substr(warn, 8, 1) ^== ',' ,
| length(warn) > 13 ,
| ((left(warn, 1) = '') <> (wAll = '')) then
return 'bad warn' warn
if wAll = '' then
return ''
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 sqlCodeWarn
sqlCodeMerge: procedure expose m.
parse arg inSu, outSu
do wx=1 to words(inSu)
su = word(inSu, wx)
call sqlCodeFromPds mCut(su, 0), su
say 'read' su m.su.0
end
call mCut all, 0
do wx=1 to words(inSu) /* each list */
su = word(inSu, wx) /* each msg in one list */
do sx=1 to m.su.0
suffs = ''
k = word(m.su.sx, 1) + 0
do qx=1 to words(inSu) /* each list */
qu = word(inSu, qx)
qy = m.qu.key.k
if symbol('m.qu.key.k') == 'VAR' ,
& m.su.sx = m.qu.qy then
suffs = suffs qu
end /* each list */
suffs = strip(suffs)
if wordPos(su, suffs) < 1 then
call err 'self missing wx' wx 'su' su 'sx' sx 'k' k
else if wordPos(su, suffs) > 1 then
iterate
if symbol('all.suffs') ^== 'VAR' then do
all.suffs = 1
call mAdd all, suffs
call mCut 'ALL.'suffs, 0
end
call mAdd 'ALL.'suffs, m.su.sx
end /* each msg in one list */
end /* each list */
call mCut o, 0
do lx=1 to m.all.0
li = m.all.lx
say 'list' li m.all.li.0
call sqlCodeConvertFormat all'.'li, o, 'sqlCodes' li
end
call writeDsn m.pref'VV)', m.o., , 1
return
endProcedure sqlCodeMerge
sqlCodeFromSource: procedure expose m.
parse arg o, mark, rel
sta = '/*<<<' mark
sto = '>>>>>' mark
sx = 0
ox = 0
do forever
do sx=sx+1 to sourceline() while ^abbrev(sourceline(sx), sta)
end
if sx > sourceline() then
leave
if wordPos(rel, sourceline(sx)) < 1 then
iterate
do sx=sx+1 to sourceline() while ^abbrev(sourceline(sx), sto)
if abbrev(sourceline(sx), ' ') then do
m.o.cd = m.o.cd || substr(sourceline(sx), 3, 70)
end
else do
if ox > 0 then
m.o.cd = strip(m.o.cd)
cd = word(sourceline(sx), 1) + 0
if symbol('m.o.cd') == 'VAR' then
call err 'duplicate sqlCodeFromSource' rel,
'line' sx sourceline(sx)
ox = ox+ 1
m.o.cd = substr(sourceline(sx), 1, 72)
end
end
end
m.o = ox
if ox > 0 then
m.o.cd = strip(m.o.cd)
return
endProcedure sqlCodeFromSource
sqlCodeFromPDS: procedure expose m.
parse arg o, suf
ox = m.o.0
sta = '/*<<<'
sto = '>>>>>'
call readDsn m.pref || suf || ')', i.
do sx=1 to i.0
if abbrev(i.sx, sta) then
iterate
if abbrev(i.sx, sto) then
iterate
if abbrev(i.sx, ' ') then do
m.o.ox = m.o.ox || substr(i.sx, 3, 70)
end
else do
ox = ox+ 1
m.o.ox = substr(i.sx, 1, 72)
k = word(m.o.ox, 1) + 0
m.o.key.k = ox
end
end
m.o.0 = ox
return
endProcedure sqlCodeFromPds
sqlCodeConvertV9: procedure expose m.
call readDsn m.pref'S9)', m.i.
call sqlCodeConvertV9Lines i, mCut(ll, 0)
call sqlCodeConvertSplitLines ll, mCut(mm, 0)
call sqlCodeConvertParameter mm
call sqlCodeConvertFormat mm, mCut(o, 0), 'sqlCodes V9'
call writeDsn m.pref'V9)', m.o., , 1
return
endProcedure sqlCodeConvertV9
sqlCodeConvertV8: procedure expose m.
call readDsn m.pref'S8)', m.i.
call sqlCodeConvertV8Lines i, mCut(ll, 0)
call sqlCodeConvertSplitLines ll, mCut(mm, 0)
call sqlCodeConvertParameter mm
call sqlCodeConvertFormat mm, mCut(o, 0), 'sqlCodes V8'
call writeDsn m.pref'V8)', m.o., , 1
return
endProcedure sqlCodeConvertV8
/*--- input sqlCode textes from db2 reference summary:
copy pasted from pdf and transfered to vb member
output lines without header footer etc. ------------------------*/
sqlCodeConvertV9lines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = strip(m.i.ix)
if right(li, 16) = 'SQL return codes' then
li = left(li, length(li) - 16)
if abbrev(li, 'Warning SQL codes') ,
| li = '¨' | li = '' ,
| subword(li, 2) == 'Reference Summary' ,
| abbrev(li, 'Chapter 4. SQL return codes') ,
| li = 'SQL return codes' then
iterate
if pos('opyrigh', li) > 0 then
call err 'remove copyright in line' ix,
'pos' pos('opyrigh', li),
substr(li, pos('opyrigh', li), 30)
call mAdd o, strip(li)
end
return
endProcedure sqlCodeConvertV9lines
/*--- input sqlCode textes from db2 reference summary:
copy pasted from pdf and transfered to vb member
output lines without header footer etc. ------------------------*/
sqlCodeConvertV8lines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = strip(m.i.ix)
if words(li) = 1 then do
w = strip(li)
if wordpos(w, 'Copyright IBM CORP Corp. Chapter SQL' ,
'1982, return codes Reference Summary') > 0 then
iterate
if datatype(w, n) then
iterate
end
if right(li, 4) = ' SQL' then
li = strip(left(li, length(li) - 4))
if pos('opyrigh', li) > 0 then
call err 'remove copyright in line' ix,
'pos' pos('opyrigh', li),
substr(li, pos('opyrigh', li), 30)
call mAdd o, strip(li)
end
return
endProcedure sqlCodeConvertV8lines
/*--- split the lines into single sql messages -----------------------*/
sqlCodeConvertSplitLines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = m.i.ix
catIt = ^ datatype(word(li, 1), n)
cx = 1
do while cx <= length(li)
e0 = cx+1
do forever
e1 = pos(' -', li, e0)
e2 = pos(' +', li, e0)
if e1 < 1 then do
if e2 < 1 then do
ex = length(li) +1
leave
end
ex = e2
end
else if e2 < 1 then
ex = e1
else
ex = min(e1, e2)
if datatype(word(substr(li, ex), 1), n) then
leave
e0 = ex+1
end
if catIt then do
ox = m.o.0
m.o.ox = m.o.ox substr(li, cx, ex-cx)
catIt = 0
end
else do
msg = substr(li, cx, ex-cx)
k = word(msg, 1)
if symbol('k.k') = 'VAR' then do
kkxx = k.k
if m.o.kkxx <> k & m.o.kkxx <> msg then
call err 'duplicate msg' msg
say 'duplicate msg' m.o.kkxx
say ' new msg' msg
m.kkxx = msg
end
else do
call mAdd o, substr(li, cx, ex-cx)
k.k = m.o.0
end
end
cx = ex+1
end
end
return
endProcedure sqlCodeConvertSplitLines
/*--- add parameter markers ${ and } ---------------------------------*/
sqlCodeConvertParameter: procedure expose m.
parse arg o
do ox=1 to m.o.0
li = strip(m.o.ox)
cx = 1
res = ''
do forever
nx = verify(li, m.mAlfLc, 'm', cx)
do while nx > 0
if nx < 1 then
leave
else if substr(li, nx, 9) = 'he XML NA' then
nx = verify(li, m.mAlfLc, 'm', nx+5)
else if substr(li, nx,25) ,
= 'he decimal number is used' then
nx = 0
else
leave
end
if nx < 1 then
leave
qx = verify(li, m.mAlfNum'-#.', 'n', nx)
if qx < 1 then
qx = length(li) + 1
res = res || substr(li, cx, nx-cx) ,
|| '${' || substr(li, nx, qx-nx) || '}'
if right(res, 2) == '.}' then
res = left(res, length(res) - 2)'}.'
cx = qx
end
m.o.ox = res || substr(li, cx)
end
return
endProcedure sqlCodeConvertParameter
/*--- split the sql messages into 72 byte lines ----------------------*/
sqlCodeConvertFormat: procedure expose m.
parse arg i, o, mark
call mAdd o, left('/*<<<' mark' ', 72, '<')
do ix=1 to m.i.0
li = strip(m.i.ix)
pr = ''
cx = 1
do forever
l = 72 - length(pr)
if cx + l > length(li) then
leave
call mAdd o, pr || substr(li, cx, l)
cx = cx + l
pr = ' '
end
call mAdd o, pr || substr(li, cx)
end
call mAdd o, left('>>>>>' mark' ', 70, '>')'*/'
return
endProcedure sqlCodeConvertFormat
m.x.xx = m.x.xx li
say 'cat' (ix-1) 'and' ix left(tt m.i.ix, 50)
end
fx = posM(li, 1, ' 000 ', ' +', ' -') + 1
if fx < 2 then
iterate
end
do xx=1 to m.xx.0
return
call adrEdit 'macro (mArgs)'
call adrEdit "(zl) = lineNum .zl"
say 'zl' zl
call mAdd mCut(o, 0), '****************'
s = 0
bef = ''
do lx = 1 to zl
call adrEdit "(li) = line" lx
li = strip(li ,'t')
if li = 'return' & (lx-1)=laLx & right(bef, 4) = ' SQL' then
bef = left(bef, length(bef)-4)
if abbrev(li, '-') | abbrev(li, '+') then do
fx = 1
end
else do
fx = posM(li, 1, ' 000 ', ' +', ' -') + 1
if fx < 2 then
iterate
end
if bef ^== '' then do
if fx > 2 then
call mAdd o, bef left(li, fx-2)
else
call mAdd o, bef
bef = ''
end
laLx = lx
do forever
tx = posM(li, fx + 3, ' 000 ', ' +', ' -')
do while tx > fx & ^ datatype(substr(li, tx+1, 3), 'n')
tx = posM(li, tx + 1, ' 000 ', ' +', ' -')
end
if tx < 1 then
leave
call mAdd o, substr(li, fx, tx+1-fx)
fx = tx + 1
end
bef = substr(li, fx)
end
if bef ^== '' then
call mAdd o, bef
do ox=1 to m.o.0
li = m.o.ox
cx = 1
res = ''
do forever
nx = verify(li, m.mAlfLc, 'm', cx)
do while nx > 0
say 'nx' nx length(li)
if nx < 1 then
leave
else if substr(li, nx, 9) = 'he XML NA' then
nx = verify(li, m.mAlfLc, 'm', nx+5)
else if substr(li, nx,25) ,
= 'he decimal number is used' then
nx = 0
else
leave
end
if nx < 1 then
leave
qx = verify(li, m.mAlfNum'-', 'n', nx)
if qx < 1 then
qx = length(li) + 1
res = res || substr(li, cx, nx-cx) ,
|| '${' || substr(li, nx, qx-nx) || '}'
cx = qx
end
m.o.ox = res || substr(li, cx)
end
do ox=1 to m.o.0
li = m.o.ox
ec = adrEdit("line_after .zl = (li)", '*')
if ec <> 0 then
say 'line_after rc' ec 'le' length(li) li
end
exit
posM: procedure expose m.
parse arg src, fx
res = 0
do ax=3 to arg()
p = pos(arg(ax), src, fx)
if p ^= 0 & (res = 0 | p < res) then
res = p
end
return res
endProcedure mPos
/* copy m begin ********************************************************
stem handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
return 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 ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
/*--- 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 '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
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, ggStem, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then do
interpret m.err.handler
return 12
end
say 'fatal error:' ggTxt
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if ggStem ^== '' then do
do ggXX=1 to m.ggStem.0
say ' ' m.ggStem.ggXX
end
if ggXX > 3 then
say 'fatal error in' ggS3':' ggTxt
end
parse source . . ggS3 . /* current rexx */
if ggOpt == 'h' 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 setRc(12)
endSubroutine err
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, st, op
say 'fatal error:' msg
call help
call err msg, st, 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
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return current time and cpu usage ------------------------------*/
showtime: 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
/*<<< sqlCodes V8 V9 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
000 SUCCESSFUL EXECUTION
+012 THE UNQUALIFIED COLUMN NAME ${column-name} WAS INTERPRETED AS A COR
RELATED REFERENCE
+098 A DYNAMIC SQL STATEMENT ENDS WITH A SEMICOLON.
+100 ROW NOT FOUND FOR FETCH, UPDATE OR DELETE, OR THE RESULT OF A QUERY
IS AN EMPTY TABLE
+110 SQL UPDATE TO A DATA CAPTURE TABLE NOT SIGNALED TO ORIGINATING SUBS
YSTEM
+111 THE SUBPAGES OPTION IS NOT SUPPORTED FOR TYPE 2 INDEXES
+117 THE NUMBER OF INSERT VALUES IS NOT THE SAME AS THE NUMBER OF OBJECT
COLUMNS
+162 TABLESPACE ${database-name.tablespace-name} HAS BEEN PLACED IN CHEC
K PENDING
+203 THE QUALIFIED COLUMN NAME ${column-name} WAS RESOLVED USING A NON-U
NIQUE OR UNEXPOSED NAME
+204 ${name} IS AN UNDEFINED NAME
+218 THE SQL STATEMENT REFERENCING A REMOTE OBJECT CANNOT BE EXPLAINED
+219 THE REQUIRED EXPLANATION TABLE ${table-name} DOES NOT EXIST
+220 THE COLUMN ${column-name} IN EXPLANATION TABLE ${table-name} IS NOT
DEFINED PROPERLY
+222 HOLE DETECTED USING CURSOR ${cursor-name}
+223 UPDATE HOLE DETECTED USING ${cursor-name}
+236 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED FOR ${integer3} COLUMNS
+238 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} SQLVAR E
NTRIES ARE NEEDED FOR ${integer3} COLUMNS BECAUSE AT LEAST ONE OF THE
COLUMNS BEING DESCRIBED IS A LOB
+239 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED FOR ${integer3} COLUMNS BECAUSE AT LEAST ONE OF THE COLUMNS BEING
DESCRIBED IS A DISTINCT TYPE
+304 A VALUE WITH DATA TYPE ${data-type1} CANNOT BE ASSIGNED TO A HOST V
ARIABLE BECAUSE THE VALUE IS NOT WITHIN THE RANGE OF THE HOST VARIABLE
IN POSITION ${position-number} WITH DATA TYPE ${data-type2}
+335 DB2 CONVERTED A HOST VARIABLE, PARAMETER, OR COLUMN NUMBER ${var-nu
m} ${var-name-or-num} TO COLUMN NAME, HOST VARIABLE, OR EXPRESSION NUM
BER ${col-name-or-num} FROM ${from} ${ccsid} TO ${to-ccsid}, AND RESUL
TING IN SUBSTITUTION CHARACTERS.
+339 THE SQL STATEMENT HAS BEEN SUCCESSFULLY EXECUTED, BUT THERE MAY BE
SOME CHARACTER CONVERSION INCONSISTENCIES
+347 THE RECURSIVE COMMON TABLE EXPRESSION ${name} MAY CONTAIN AN INFINI
TE LOOP
+402 LOCATION ${location} IS UNKNOWN
+403 THE LOCAL OBJECT REFERENCED BY THE CREATE ALIAS STATEMENT DOES NOT
EXIST
+445 VALUE ${value} HAS BEEN TRUNCATED
+462 EXTERNAL FUNCTION OR PROCEDURE ${name} (SPECIFIC NAME ${specific-na
me}) HAS RETURNED A WARNING SQLSTATE, WITH DIAGNOSTIC TEXT ${text}
+464 PROCEDURE ${proc} RETURNED ${num} QUERY RESULT SETS, WHICH EXCEEDS
THE DEFINED LIMIT ${integer}
+466 PROCEDURE ${proc} RETURNED ${num} QUERY RESULTS SETS
+494 NUMBER OF RESULT SETS IS GREATER THAN NUMBER OF LOCATORS
+495 ESTIMATED PROCESSOR COST OF ${estimate-amount1} PROCESSOR SECONDS (
${estimate-amount2} SERVICE UNITS) IN COST CATEGORY ${cost-category} E
XCEEDS A RESOURCE LIMIT WARNING THRESHOLD OF ${limit-} ${amount} SERVI
CE UNITS
+535 THE RESULT OF THE POSITIONED UPDATE OR DELETE MAY DEPEND ON THE ORD
ER OF THE ROWS
+541 THE REFERENTIAL OR UNIQUE CONSTRAINT ${name} HAS BEEN IGNORED BECAU
SE IT IS A DUPLICATE
+551 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion} ON OBJECT ${object-name}
+552 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion}
+558 THE WITH GRANT OPTION IS IGNORED
+561 THE ALTER, INDEX, REFERENCES, AND TRIGGER PRIVILEGES CANNOT BE GRAN
TED PUBLIC AT ALL LOCATIONS
+562 A GRANT OF A PRIVILEGE WAS IGNORED BECAUSE THE GRANTEE ALREADY HAS
THE PRIVILEGE FROM THE GRANTOR
+599 COMPARISON FUNCTIONS ARE NOT CREATED FOR A DISTINCT TYPE BASED ON A
LONG STRING DATA TYPE
+610 A CREATE/ALTER ON OBJECT ${object-name} HAS PLACED OBJECT IN ${util
ity} PENDING
+650 THE TABLE BEING CREATED OR ALTERED CANNOT BECOME A DEPENDENT TABLE
+653 TABLE ${table-name} IN PARTITIONED TABLESPACE ${tspace-name} IS NOT
AVAILABLE BECAUSE ITS PARTITIONED INDEX HAS NOT BEEN CREATED
+655 STOGROUP ${stogroup}_${name} HAS BOTH SPECIFIC AND NON-SPECIFIC VOL
UME IDS. IT WILL NOT BE ALLOWED IN FUTURE RELEASES
+658 THE SUBPAGES VALUE IS IGNORED FOR THE CATALOG INDEX ${index-name}
+738 DEFINITION CHANGE OF ${object} ${object}_${name} MAY REQUIRE SIMILA
R CHANGE ON READ-ONLY SYSTEMS
+799 A SET STATEMENT REFERENCES A SPECIAL REGISTER THAT DOES NOT EXIST A
T THE SERVER SITE
+802 EXCEPTION ERROR ${exception-type} HAS OCCURRED DURING ${operation-t
ype} OPERATION ON ${data-type} DATA, POSITION ${position-number}
+806 BIND ISOLATION LEVEL RR CONFLICTS WITH TABLESPACE LOCKSIZE PAGE OR
LOCKSIZE ROW AND LOCKMAX 0
+807 THE RESULT OF DECIMAL MULTIPLICATION MAY CAUSE OVERFLOW
+863 THE CONNECTION WAS SUCCESSFUL BUT ONLY SBCS WILL BE SUPPORTED
+883 ROLLBACK TO SAVEPOINT OCCURED WHEN THERE WERE OPERATIONS THAT CANNO
T BE UNDONE, OR AN OPERATION THAT CANNOT BE UNDONE OCCURRED WHEN THERE
WAS A SAVEPOINT OUTSTANDING
+2000 TYPE 1 INDEXES WITH SUBPAGES GREATER THAN 1 CANNOT BECOME GROUP BU
FFER POOL DEPENDENT IN A DATA SHARING ENVIRONMENT
+20122 DEFINE NO OPTION IS NOT APPLICABLE IN THE CONTEXT SPECIFIED
-007 STATEMENT CONTAINS THE ILLEGAL CHARACTER ${character}
-010 THE STRING CONSTANT BEGINNING ${string} IS NOT TERMINATED
-016 ${token} REQUIRED
-029 INTO CLAUSE REQUIRED
-060 INVALID ${type} SPECIFICATION : ${spec}
-084 UNACCEPTABLE SQL STATEMENT
-097 THE USE OF LONG VARCHAR OR LONG VARGRAPHIC IS NOT ALLOWED IN THIS C
ONTEXT
-104 ILLEGAL SYMBOL ?${token}?. SOME SYMBOLS THAT MIGHT BE LEGAL ARE: ${
token-list}
-105 INVALID STRING
-107 THE NAME ${name} IS TOO LONG. MAXIMUM ALLOWABLE SIZE IS ${size}
-108 THE NAME ${name} IS QUALIFIED INCORRECTLY
-109 ${clause} CLAUSE IS NOT PERMITTED
-111 A COLUMN FUNCTION DOES NOT INCLUDE A COLUMN NAME
-114 THE LOCATION NAME ${location} DOES NOT MATCH THE CURRENT SERVER
-115 A PREDICATE IS INVALID BECAUSE THE COMPARISON OPERATOR ${operator}
IS FOLLOWED BY A PARENTHESIZED LIST OR BY ANY OR ALL WITHOUT A SUBQUER
Y
-117 THE NUMBER OF VALUES ASSIGNED IS NOT THE SAME AS THE NUMBER OF SPEC
IFIED OR IMPLIED COLUMNS
-118 THE OBJECT TABLE OR VIEW OF THE DELETE OR UPDATE STATEMENT IS ALSO
IDENTIFIED IN A FROM CLAUSE
-123 THE PARAMETER IN POSITION ${n} IN THE FUNCTION ${name} MUST BE A CO
NSTANT OR KEYWORD
-125 AN INTEGER IN THE ORDER BY CLAUSE DOES NOT IDENTIFY A COLUMN OF THE
RESULT
-126 THE SELECT STATEMENT CONTAINS BOTH AN UPDATE CLAUSE AND AN ORDER BY
CLAUSE
-128 INVALID USE OF NULL IN A PREDICATE
-129 THE STATEMENT CONTAINS TOO MANY TABLE NAMES
-130 THE ESCAPE CLAUSE CONSISTS OF MORE THAN ONE CHARACTER, OR THE STRIN
G PATTERN CONTAINS AN INVALID OCCURRENCE OF THE ESCAPE CHARACTER
-131 STATEMENT WITH LIKE PREDICATE HAS INCOMPATIBLE DATA TYPES
-132 AN OPERAND OF ${value} IS NOT VALID
-133 AN AGGREGATE FUNCTION IN A SUBQUERY OF A HAVING CLAUSE IS INVALID B
ECAUSE ALL COLUMN REFERENCES IN ITS ARGUMENT ARE NOT CORRELATED TO THE
GROUP BY RESULT THAT THE HAVING CLAUSE IS APPLIED TO
-137 THE LENGTH RESULTING FROM ${operation} IS GREATER THAN ${maximum-le
ngth}
-142 THE SQL STATEMENT IS NOT SUPPORTED
-144 INVALID SECTION NUMBER ${number}
-152 THE DROP ${clause} CLAUSE IN THE ALTER STATEMENT IS INVALID BECAUSE
${constraint-name} IS A ${constraint-type}
-153 THE STATEMENT IS INVALID BECAUSE THE VIEW OR TABLE DEFINITION DOES
NOT INCLUDE A UNIQUE NAME FOR EACH COLUMN
-154 THE STATEMENT FAILED BECAUSE VIEW OR TABLE DEFINITION IS NOT VALID
-156 THE STATEMENT DOES NOT IDENTIFY A TABLE
-157 ONLY A TABLE NAME CAN BE SPECIFIED IN A FOREIGN KEY CLAUSE. ${objec
t-name} IS NOT THE NAME OF A TABLE.
-158 THE NUMBER OF COLUMNS SPECIFIED FOR THE VIEW OR TABLE IS NOT THE SA
ME AS THE NUMBER OF COLUMNS SPECIFIED BY THE FULLSELECT, OR THE NUMBER
OF COLUMNS SPECIFIED IN THE CORRELATION CLAUSE IN A FROM CLAUSE IS NO
T THE SAME AS THE NUMBER OF COLUMNS IN THE CORRESPONDING TABLE, VIEW,
TABLE EXPRESSION, OR TABLE FUNCTION
-161 THE INSERT OR UPDATE IS NOT ALLOWED BECAUSE A RESULTING ROW DOES NO
T SATISFY THE VIEW DEFINITION
-164 ${auth-id1} DOES NOT HAVE THE PRIVILEGE TO CREATE A VIEW WITH QUALI
FICATION ${authorization-ID}
-170 THE NUMBER OF ARGUMENTS SPECIFIED FOR ${function-name} IS INVALID
-171 THE DATA TYPE, LENGTH, OR VALUE OF ARGUMENT ${nn} OF ${function-nam
e} IS INVALID
-173 UR IS SPECIFIED ON THE WITH CLAUSE BUT THE CURSOR IS NOT READ-ONLY
-180 THE DATE, TIME, OR TIMESTAMP VALUE ${value} IS INVALID
-181 THE STRING REPRESENTATION OF A DATETIME VALUE IS NOT A VALID DATETI
ME VALUE
-182 AN ARITHMETIC EXPRESSION WITH A DATETIME VALUE IS INVALID
-183 AN ARITHMETIC OPERATION ON A DATE OR TIMESTAMP HAS A RESULT THAT IS
NOT WITHIN THE VALID RANGE OF DATES
-184 AN ARITHMETIC EXPRESSION WITH A DATETIME VALUE CONTAINS A PARAMETER
MARKER
-185 THE LOCAL FORMAT OPTION HAS BEEN USED WITH A DATE OR TIME AND NO LO
CAL EXIT HAS BEEN INSTALLED
-186 THE LOCAL DATE LENGTH OR LOCAL TIME LENGTH HAS BEEN INCREASED AND E
XECUTING PROGRAM RELIES ON THE OLD LENGTH
-188 THE STRING REPRESENTATION OF A NAME IS INVALID
-191 A STRING CANNOT BE USED BECAUSE IT IS INVALID MIXED DATA
-198 THE OPERAND OF THE PREPARE OR EXECUTE IMMEDIATE STATEMENT IS BLANK
OR EMPTY
-199 ILLEGAL USE OF KEYWORD ${keyword}. TOKEN ${token-list} WAS EXPECTED
-203 A REFERENCE TO COLUMN ${column-name} IS AMBIGUOUS
-204 ${name} IS AN UNDEFINED NAME
-205 ${column-name} IS NOT A COLUMN OF TABLE ${table-name}
-208 THE ORDER BY CLAUSE IS INVALID BECAUSE COLUMN ${name} IS NOT PART O
F THE RESULT TABLE
-212 ${name} IS SPECIFIED MORE THAN ONCE IN THE REFERENCING CLAUSE OF A
TRIGGER DEFINITION
-214 AN EXPRESSION IN THE FOLLOWING POSITION, OR STARTING WITH ${positio
n-or-expression-start} IN THE ${clause-type} CLAUSE IS NOT VALID. REAS
ON CODE = ${reason-code}
-216 THE NUMBER OF ELEMENTS ON EACH SIDE OF A PREDICATE OPERATOR DOES NO
T MATCH. PREDICATE OPERATOR IS ${operator}.
-219 THE REQUIRED EXPLANATION TABLE ${table-name} DOES NOT EXIST
-220 THE COLUMN ${column-name} IN EXPLANATION TABLE ${table-name} IS NOT
DEFINED PROPERLY
-221 SET OF OPTIONAL COLUMNS IN EXPLANATION TABLE ${table-name} IS INC
OMPLETE. OPTIONAL COLUMN ${column-name} IS MISSING
-223 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST AN UPDATE HOLE
USING ${cursor-name}
-224 THE RESULT TABLE DOES NOT AGREE WITH THE BASE TABLE USING ${cursor-
name}
-227 FETCH ${fetch-orientation} IS NOT ALLOWED, BECAUSE CURSOR ${cursor-
name} HAS AN UNKNOWN POSITION (${sqlcode},${sqlstate})
-228 FOR UPDATE CLAUSE SPECIFIED FOR READ-ONLY CURSOR ${cursor-name}
-243 SENSITIVE CURSOR ${cursor-name} CANNOT BE DEFINED FOR THE SPECIFIED
SELECT STATEMENT
-244 SENSITIVITY ${sensitivity} SPECIFIED ON THE FETCH IS NOT VALID FOR
CURSOR ${cursor-name}
-246 STATEMENT USING CURSOR ${cursor-name} SPECIFIED NUMBER OF ROWS ${nu
m-rows} WHICH IS NOT VALID WITH ${dimension}
-247 A HOLE WAS DETECTED ON A MULTIPLE ROW FETCH STATEMENT USING CURSOR
${cursor-name}, BUT INDICATOR VARIABLES WERE NOT PROVIDED TO DETECT TH
E CONDITION
-248 A POSITIONED DELETE OR UPDATE STATEMENT FOR CURSOR ${cursor-name} S
PECIFIED ROW ${n} OF A ROWSET, BUT THE ROW IS NOT CONTAINED WITHIN THE
CURRENT ROWSET
-249 DEFINITION OF ROWSET ACCESS FOR CURSOR ${cursor-name} IS INCONSISTE
NT WITH THE FETCH ORIENTATION CLAUSE ${clause} SPECIFIED
-250 THE LOCAL LOCATION NAME IS NOT DEFINED WHEN PROCESSING A THREE-PART
OBJECT NAME
-251 TOKEN ${name} IS NOT VALID
-270 FUNCTION NOT SUPPORTED
-300 THE STRING CONTAINED IN HOST VARIABLE OR PARAMETER ${position-numbe
r} IS NOT NUL-TERMINATED
-301 THE VALUE OF INPUT HOST VARIABLE OR PARAMETER NUMBER ${position-num
ber} CANNOT BE USED AS SPECIFIED BECAUSE OF ITS DATA TYPE
-302 THE VALUE OF INPUT VARIABLE OR PARAMETER NUMBER ${position-number}
IS INVALID OR TOO LARGE FOR THE TARGET COLUMN OR THE TARGET VALUE
-303 A VALUE CANNOT BE ASSIGNED TO OUTPUT HOST VARIABLE NUMBER ${positio
n-number} BECAUSE THE DATA TYPES ARE NOT COMPARABLE
-304 A VALUE WITH DATA TYPE ${data-type1} CANNOT BE ASSIGNED TO A HOST V
ARIABLE BECAUSE THE VALUE IS NOT WITHIN THE RANGE OF THE HOST VARIABLE
IN POSITION ${position-number} WITH DATA TYPE ${data-type2}
-305 THE NULL VALUE CANNOT BE ASSIGNED TO OUTPUT HOST VARIABLE NUMBER ${
position-number} BECAUSE NO INDICATOR VARIABLE IS SPECIFIED
-309 A PREDICATE IS INVALID BECAUSE A REFERENCED HOST VARIABLE HAS THE N
ULL VALUE
-310 DECIMAL HOST VARIABLE OR PARAMETER ${number} CONTAINS NON-DECIMAL D
ATA
-311 THE LENGTH OF INPUT HOST VARIABLE NUMBER ${position-number} IS NEGA
TIVE OR GREATER THAN THE MAXIMUM
-313 THE NUMBER OF HOST VARIABLES SPECIFIED IS NOT EQUAL TO THE NUMBER O
F PARAMETER MARKERS
-314 THE STATEMENT CONTAINS AN AMBIGUOUS HOST VARIABLE REFERENCE
-327 THE ROW CANNOT BE INSERTED BECAUSE IT IS OUTSIDE THE BOUND OF THE P
ARTITION RANGE FOR THE LAST PARTITION
-332 CHARACTER CONVERSION BETWEEN CCSID ${from-ccsid} TO ${to-ccsid} REQ
UESTED BY ${reason-code} IS NOT SUPPORTED
-338 AN ON CLAUSE IS INVALID
-339 THE SQL STATEMENT CANNOT BE EXECUTED FROM AN ASCII BASED DRDA APPLI
CATION REQUESTOR TO A V2R2 DB2 SUBSYSTEM
-340 THE COMMON TABLE EXPRESSION ${name} HAS THE SAME IDENTIFIER AS ANOT
HER OCCURRENCE OF A COMMON TABLE EXPRESSION DEFINITION WITHIN THE SAME
STATEMENT
-341 A CYCLIC REFERENCE EXISTS BETWEEN THE COMMON TABLE EXPRESSIONS ${na
me1} AND ${name2}
-343 THE COLUMN NAMES ARE REQUIRED FOR THE RECURSIVE COMMON TABLE EXPRES
SION ${name}
-346 AN INVALID REFERENCE TO COMMON TABLE EXPRESSION ${name} OCCURS IN T
HE FIRST FULLSELECT, AS A SECOND OCCURRENCE IN THE SAME FROM CLAUSE, O
R IN THE FROM CLAUSE OF A SUBQUERY
-351 AN UNSUPPORTED SQLTYPE WAS ENCOUNTERED IN POSITION ${position-numbe
r} OF THE SELECT-LIST
-352 AN UNSUPPORTED SQLTYPE WAS ENCOUNTERED IN POSITION ${position-numbe
r} OF THE INPUT-LIST
-355 A LOB COLUMN IS TOO LARGE TO BE LOGGED
-359 THE RANGE OF VALUES FOR THE IDENTITY COLUMN OR SEQUENCE IS EXHAUSTE
D
-392 SQLDA PROVIDED FOR CURSOR ${cursor} HAS BEEN CHANGED FROM THE PREVI
OUS FETCH
-393 THE CONDITION OR CONNECTION NUMBER IS INVALID
-396 ${object-type} ${object-name} ATTEMPTED TO EXECUTE AN SQL STATEMENT
DURING FINAL CALL PROCESSING
-398 A LOCATOR WAS REQUESTED FOR HOST VARIABLE NUMBER ${position-number}
BUT THE VARIABLE IS NOT A LOB
-400 THE CATALOG HAS THE MAXIMUM NUMBER OF USER DEFINED INDEXES
-401 THE OPERANDS OF AN ARITHMETIC OR COMPARISON OPERATION ARE NOT COMPA
RABLE
-402 AN ARITHMETIC FUNCTION OR OPERATOR ${arith-fop} IS APPLIED TO CHARA
CTER OR DATETIME DATA
-404 THE SQL STATEMENT SPECIFIES A STRING THAT IS TOO LONG
-406 A CALCULATED OR DERIVED NUMERIC VALUE IS NOT WITHIN THE RANGE OF IT
S OBJECT COLUMN
-407 AN UPDATE, INSERT, OR SET VALUE IS NULL, BUT THE OBJECT COLUMN ${co
lumn-name} CANNOT CONTAIN NULL VALUES
-409 INVALID OPERAND OF A COUNT FUNCTION
-411 CURRENT SQLID CANNOT BE USED IN A STATEMENT THAT REFERENCES REMOTE
OBJECTS
-412 THE SELECT CLAUSE OF A SUBQUERY SPECIFIES MULTIPLE COLUMNS
-413 OVERFLOW OCCURRED DURING NUMERIC DATA TYPE CONVERSION
-414 A LIKE PREDICATE IS INVALID BECAUSE THE FIRST OPERAND IS NOT A STRI
NG
-417 A STATEMENT STRING TO BE PREPARED INCLUDES PARAMETER MARKERS AS THE
OPERANDS OF THE SAME OPERATOR
-418 A STATEMENT STRING TO BE PREPARED CONTAINS AN INVALID USE OF PARAME
TER MARKERS
-419 THE DECIMAL DIVIDE OPERATION IS INVALID BECAUSE THE RESULT WOULD HA
VE A NEGATIVE SCALE
-420 THE VALUE OF A STRING ARGUMENT WAS NOT ACCEPTABLE TO THE ${function
-name} FUNCTION
-423 INVALID VALUE FOR LOCATOR IN POSITION ${position-#}
-426 DYNAMIC COMMIT NOT VALID AT AN APPLICATION SERVER WHERE UPDATES ARE
NOT ALLOWED
-427 DYNAMIC ROLLBACK NOT VALID AT AN APPLICATION SERVER WHERE UPDATES A
RE NOT ALLOWED
-430 ${routine-type} ${routine-name} (SPECIFIC NAME ${specific-name}) HA
S ABNORMALLY TERMINATED
-433 VALUE ${value} IS TOO LONG
-438 APPLICATION RAISED ERROR WITH DIAGNOSTIC TEXT: ${text}
-444 USER PROGRAM ${name} COULD NOT BE FOUND
-449 CREATE OR ALTER STATEMENT FOR FUNCTION OR PROCEDURE ${routine-name}
CONTAINS AN INVALID FORMAT OF THE EXTERNAL NAME CLAUSE OR IS MISSING
THE EXTERNAL NAME CLAUSE
-450 USER-DEFINED FUNCTION OR STORED PROCEDURE ${name}, PARAMETER NUMBER
${parmnum}, OVERLAYED STORAGE BEYOND ITS DECLARED LENGTH.
-453 THERE IS A PROBLEM WITH THE RETURNS CLAUSE IN THE CREATE FUNCTION S
TATEMENT FOR ${function-name}
-454 THE SIGNATURE PROVIDED IN THE CREATE FUNCTION STATEMENT FOR ${funct
ion-name} MATCHES THE SIGNATURE OF SOME OTHER FUNCTION ALREADY EXISTIN
G IN THE SCHEMA
-455 IN CREATE FUNCTION FOR ${function-name}, THE SCHEMA NAME ${schema-n
ame1} PROVIDED FOR THE SPECIFIC NAME DOES NOT MATCH THE SCHEMA NAME ${
schema-name2} OF THE FUNCTION
-456 IN CREATE FUNCTION FOR ${function-name}, THE SPECIFIC NAME ${specif
ic-name} ALREADY EXISTS IN THE SCHEMA
-457 A FUNCTION OR DISTINCT TYPE CANNOT BE CALLED ${name} SINCE IT IS RE
SERVED FOR SYSTEM USE
-458 IN A REFERENCE TO FUNCTION ${function-name} BY SIGNATURE, A MATCHIN
G FUNCTION COULD NOT BE FOUND
-461 A VALUE WITH DATA TYPE ${source-data-type} CANNOT BE CAST TO TYPE $
{target-data-type}
-469 SQL CALL STATEMENT MUST SPECIFY AN OUTPUT HOST VARIABLE FOR PARAMET
ER ${number}
-470 SQL CALL STATEMENT SPECIFIED A NULL VALUE FOR INPUT PARAMETER ${num
ber}, BUT THE STORED PROCEDURE DOES NOT SUPPORT NULL VALUES.
-471 INVOCATION OF FUNCTION OR PROCEDURE ${name} FAILED DUE TO REASON ${
rc}
-472 CURSOR ${cursor-name} WAS LEFT OPEN BY EXTERNAL FUNCTION ${function
-name} (SPECIFIC NAME ${specific-name})
-473 A USER DEFINED DATA TYPE CANNOT BE CALLED THE SAME NAME AS A SYSTEM
PREDEFINED TYPE (BUILT-IN TYPE)
-475 THE RESULT TYPE ${type-1} OF THE SOURCE FUNCTION CANNOT BE CAST TO
THE RETURNS TYPE ${type-2} OF THE USER-DEFINED FUNCTION ${function-nam
e}
-476 REFERENCE TO FUNCTION ${function-name} WAS NAMED WITHOUT A SIGNATUR
E, BUT THE FUNCTION IS NOT UNIQUE WITHIN ITS SCHEMA
-478 DROP OR REVOKE ON OBJECT TYPE ${type1} CANNOT BE PROCESSED BECAUSE
OBJECT ${name} OF TYPE ${type2} IS DEPENDENT ON IT
-480 THE PROCEDURE ${procedure-name} HAS NOT YET BEEN CALLED
-482 THE PROCEDURE ${procedure-name} RETURNED NO LOCATORS
-483 IN CREATE FUNCTION FOR ${function-name} STATEMENT, THE NUMBER OF PA
RAMETERS DOES NOT MATCH THE NUMBER OF PARAMETERS OF THE SOURCE FUNCTIO
N
-487 ${object-type} ${object-name} ATTEMPTED TO EXECUTE AN SQL STATEMENT
WHEN THE DEFINITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS
ACTION
-490 NUMBER ${number} DIRECTLY SPECIFIED IN AN SQL STATEMENT IS OUTSIDE
THE RANGE OF ALLOWABLE VALUES IN THIS CONTEXT (${minval}, ${maxval})
-491 CREATE STATEMENT FOR USER-DEFINED FUNCTION ${function-name} MUST HA
VE A RETURNS CLAUSE AND: THE EXTERNAL CLAUSE WITH OTHER REQUIRED KEYWO
RDS; THE RETURN STATEMENT AND PARAMETER NAMES; OR THE SOURCE CLAUSE
-492 THE CREATE FUNCTION FOR ${function-name} HAS A PROBLEM WITH PARAMET
ER NUMBER ${number}. IT MAY INVOLVE A MISMATCH WITH A SOURCE FUNCTION
-495 ESTIMATED PROCESSOR COST OF ${estimate-amount1} PROCESSOR SECONDS (
${estimate-amount2} SERVICE UNITS) IN COST CATEGORY ${cost-category} E
XCEEDS A RESOURCE LIMIT ERROR THRESHOLD OF ${limit-} ${amount} SERVICE
UNITS
-496 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT REFERENCES A RESULT
SET THAT WAS NOT CREATED BY THE CURRENT SERVER
-497 THE MAXIMUM LIMIT OF INTERNAL IDENTIFIERS HAS BEEN EXCEEDED FOR DAT
ABASE ${database-name}
-499 CURSOR ${cursor-name} HAS ALREADY BEEN ASSIGNED TO THIS OR ANOTHER
RESULT SET FROM PROCEDURE ${procedure-name}.
-500 THE IDENTIFIED CURSOR WAS CLOSED WHEN THE CONNECTION WAS DESTROYED
-501 THE CURSOR IDENTIFIED IN A FETCH OR CLOSE STATEMENT IS NOT OPEN
-502 THE CURSOR IDENTIFIED IN AN OPEN STATEMENT IS ALREADY OPEN
-503 A COLUMN CANNOT BE UPDATED BECAUSE IT IS NOT IDENTIFIED IN THE UPDA
TE CLAUSE OF THE SELECT STATEMENT OF THE CURSOR
-507 THE CURSOR IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT OPEN
-508 THE CURSOR IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT POSI
TIONED ON A ROW OR ROWSET THAT CAN BE UPDATED OR DELETED
-509 THE TABLE IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT THE S
AME TABLE DESIGNATED BY THE CURSOR
-510 THE TABLE DESIGNATED BY THE CURSOR OF THE UPDATE OR DELETE STATEMEN
T CANNOT BE MODIFIED
-512 STATEMENT REFERENCE TO REMOTE OBJECT IS INVALID
-513 THE ALIAS ${alias-name} MUST NOT BE DEFINED ON ANOTHER LOCAL OR REM
OTE ALIAS
-514 THE CURSOR ${cursor-name} IS NOT IN A PREPARED STATE
-517 CURSOR ${cursor-name} CANNOT BE USED BECAUSE ITS STATEMENT NAME DOE
S NOT IDENTIFY A PREPARED SELECT STATEMENT
-518 THE EXECUTE STATEMENT DOES NOT IDENTIFY A VALID PREPARED STATEMENT
-519 THE PREPARE STATEMENT IDENTIFIES THE SELECT STATEMENT OF THE OPENED
CURSOR ${cursor-name}
-530 THE INSERT OR UPDATE VALUE OF FOREIGN KEY ${constraint-name} IS INV
ALID
-531 PARENT KEY IN A PARENT ROW CANNOT BE UPDATED BECAUSE IT HAS ONE OR
MORE DEPENDENT ROWS IN RELATIONSHIP ${constraint-name}
-533 INVALID MULTIPLE-ROW INSERT
-534 THE PRIMARY KEY CANNOT BE UPDATED BECAUSE OF MULTIPLE-ROW UPDATE
-536 THE DELETE STATEMENT IS INVALID BECAUSE TABLE ${table-name} CAN BE
AFFECTED BY THE OPERATION
-537 THE PRIMARY KEY, FOREIGN KEY, UNIQUE, OR PARTITIONING KEY CLAUSE ID
ENTIFIES COLUMN ${column-name} MORE THAN ONCE
-538 FOREIGN KEY ${name} DOES NOT CONFORM TO THE DESCRIPTION OF A PARENT
KEY OF TABLE ${table-name}
-539 TABLE ${table-name} DOES NOT HAVE A PRIMARY KEY
-540 THE DEFINITION OF TABLE ${table-name} IS INCOMPLETE BECAUSE IT LACK
S A PRIMARY INDEX OR A REQUIRED UNIQUE INDEX
-542 ${column-name} CANNOT BE A COLUMN OF A PRIMARY KEY, A UNIQUE CONSTR
AINT, OR A PARENT KEY BECAUSE IT CAN CONTAIN NULL VALUES
-543 A ROW IN A PARENT TABLE CANNOT BE DELETED BECAUSE THE CHECK CONSTRA
INT ${check-constraint} RESTRICTS THE DELETION
-544 THE CHECK CONSTRAINT SPECIFIED IN THE ALTER TABLE STATEMENT CANNOT
BE ADDED BECAUSE AN EXISTING ROW VIOLATES THE CHECK CONSTRAINT
-545 THE REQUESTED OPERATION IS NOT ALLOWED BECAUSE A ROW DOES NOT SATIS
FY THE CHECK CONSTRAINT ${check-constraint}
-546 THE CHECK CONSTRAINT ${constraint-name} IS INVALID
-548 A CHECK CONSTRAINT THAT IS DEFINED WITH ${column-name} IS INVALID
-549 THE ${statement} STATEMENT IS NOT ALLOWED FOR ${object}_${type1} ${
object}_${name} BECAUSE THE BIND OPTION DYNAMICRULES(RUN) IS NOT IN EF
FECT FOR ${object}_${type2}
-551 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion} ON OBJECT ${object-name}
-552 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion}
-556 ${authid2} CANNOT HAVE THE ${privilege} PRIVILEGE ${on}_${object} R
EVOKED BY ${authid1} BECAUSE THE REVOKEE DOES NOT POSSESS THE PRIVILEG
E OR THE REVOKER DID NOT MAKE THE GRANT
-557 INCONSISTENT GRANT/REVOKE KEYWORD ${keyword}. PERMITTED KEYWORDS AR
E ${keyword-list}
-558 INVALID CLAUSE OR COMBINATION OF CLAUSES ON A GRANT OR REVOKE
-559 ALL AUTHORIZATION FUNCTIONS HAVE BEEN DISABLED
-567 ${bind-type} AUTHORIZATION ERROR USING ${auth-id} AUTHORITY PACKAGE
= ${package-name} PRIVILEGE = ${privilege}
-571 THE STATEMENT WOULD RESULT IN A MULTIPLE SITE UPDATE
-573 TABLE ${table-name} DOES NOT HAVE A UNIQUE KEY WITH THE SPECIFIED C
OLUMN NAMES
-574 THE SPECIFIED DEFAULT VALUE OR IDENTITY ATTRIBUTE VALUE CONFLICTS W
ITH THE DEFINITION OF COLUMN ${column-name}
-577 ${object-type} ${object-name} ATTEMPTED TO MODIFY DATA WHEN THE DEF
INITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS ACTION
-579 ${object-type} ${object-name} ATTEMPTED TO READ DATA WHEN THE DEFIN
ITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS ACTION
-580 THE RESULT-EXPRESSIONS OF A CASE EXPRESSION CANNOT ALL BE NULL
-581 THE DATA TYPES OF THE RESULT-EXPRESSIONS OF A CASE EXPRESSION ARE N
OT COMPATIBLE
-582 THE SEARCH-CONDITION IN A SEARCHED-WHEN-CLAUSE CANNOT BE A QUANTIFI
ED PREDICATE, IN PREDICATE, OR AN EXISTS PREDICATE.
-587 A LIST OF ${item-references} ARE NOT IN THE SAME FAMILY
-589 A POSITIONED DELETE OR UPDATE STATEMENT FOR CURSOR ${cursor-name} S
PECIFIED A ROW OF A ROWSET, BUT THE CURSOR IS NOT POSITIONED ON A ROWS
ET
-592 NOT AUTHORIZED TO CREATE FUNCTIONS OR PROCEDURES IN WLM ENVIRONMENT
${env-name}
-594 ATTEMPT TO CREATE A NULLABLE ROWID OR DISTINCT TYPE COLUMN ${column
-name}
-603 A UNIQUE INDEX CANNOT BE CREATED BECAUSE THE TABLE CONTAINS ROWS WH
ICH ARE DUPLICATES WITH RESPECT TO THE VALUES OF THE IDENTIFIED COLUMN
S
-604 A DATA TYPE DEFINITION SPECIFIES AN INVALID LENGTH, PRECISION, OR S
CALE ATTRIBUTE
-607 OPERATION OR OPTION ${operation} IS NOT DEFINED FOR THIS OBJECT
-611 ONLY LOCKMAX 0 CAN BE SPECIFIED WHEN THE LOCK SIZE OF THE TABLESPAC
E IS TABLESPACE OR TABLE
-613 THE PRIMARY KEY OR A UNIQUE CONSTRAINT IS TOO LONG OR HAS TOO MANY
COLUMNS
-614 THE INDEX CANNOT BE CREATED OR ALTERED, OR THE LENGTH OF A COLUMN C
ANNOT BE CHANGED BECAUSE THE SUM OF THE INTERNAL LENGTHS OF THE COLUMN
S FOR THE INDEX IS GREATER THAN THE ALLOWABLE MAXIMUM
-615 ${operation-type} IS NOT ALLOWED ON A PACKAGE IN USE
-616 ${obj-type1} ${obj-name1} CANNOT BE DROPPED BECAUSE IT IS REFERENCE
D BY ${obj-type2} ${obj-name2}
-617 A TYPE 1 INDEX IS NOT VALID FOR TABLE ${table-name}
-618 OPERATION ${operation} IS NOT ALLOWED ON SYSTEM DATABASES
-619 OPERATION DISALLOWED BECAUSE THE DATABASE IS NOT STOPPED
-621 DUPLICATE DBID ${dbid} WAS DETECTED AND PREVIOUSLY ASSIGNED TO ${da
tabase-name}
-622 FOR MIXED DATA IS INVALID BECAUSE THE MIXED DATA INSTALL OPTION IS
NO
-623 A CLUSTERING INDEX ALREADY EXISTS ON TABLE ${table-name}
-625 TABLE ${table-name} DOES NOT HAVE AN INDEX TO ENFORCE THE UNIQUENES
S OF THE PRIMARY OR UNIQUE KEY
-626 THE ALTER STATEMENT IS NOT EXECUTABLE BECAUSE THE PAGE SET IS NOT S
TOPPED
-628 THE CLAUSES ARE MUTUALLY EXCLUSIVE
-629 SET NULL CANNOT BE SPECIFIED BECAUSE FOREIGN KEY ${name} CANNOT CON
TAIN NULL VALUES
-630 THE WHERE NOT NULL SPECIFICATION IS INVALID FOR TYPE 1 INDEXES
-631 FOREIGN KEY ${name} IS TOO LONG OR HAS TOO MANY COLUMNS
-632 THE TABLE CANNOT BE DEFINED AS A DEPENDENT OF ${table-name} BECAUSE
OF DELETE RULE RESTRICTIONS
-633 THE DELETE RULE MUST BE ${delete-rule}
-634 THE DELETE RULE MUST NOT BE CASCADE
-635 THE DELETE RULES CANNOT BE DIFFERENT OR CANNOT BE SET NULL
-638 TABLE ${table-name} CANNOT BE CREATED BECAUSE COLUMN DEFINITION IS
MISSING
-639 A NULLABLE COLUMN OF A FOREIGN KEY WITH A DELETE RULE OF SET NULL C
ANNOT BE A COLUMN OF THE KEY OF A PARTITIONED INDEX
-640 LOCKSIZE ROW CANNOT BE SPECIFIED BECAUSE TABLE IN THIS TABLESPACE H
AS TYPE 1 INDEX
-646 TABLE ${table-name} CANNOT BE CREATED IN SPECIFIED TABLE SPACE ${ta
ble-space-name} BECAUSE IT ALREADY CONTAINS A TABLE
-650 THE ALTER STATEMENT CANNOT BE EXECUTED, REASON ${reason}
-651 TABLE DESCRIPTION EXCEEDS MAXIMUM SIZE OF OBJECT DESCRIPTOR.
-652 VIOLATION OF INSTALLATION DEFINED EDIT OR VALIDATION PROCEDURE ${pr
oc-name}
-653 TABLE ${table-name} IN PARTITIONED TABLE SPACE ${tspace-name} IS NO
T AVAILABLE BECAUSE ITS PARTITIONED INDEX HAS NOT BEEN CREATED
-655 THE CREATE OR ALTER STOGROUP IS INVALID BECAUSE THE STORAGE GROUP W
OULD HAVE BOTH SPECIFIC AND NON-SPECIFIC VOLUME IDS
-658 A ${object-type} CANNOT BE DROPPED USING THE ${statement} STATEMENT
-660 INDEX ${index-name} CANNOT BE CREATED OR ALTERED ON PARTITIONED TAB
LE SPACE ${tspace-name} BECAUSE KEY LIMITS ARE NOT SPECIFIED
-663 THE NUMBER OF KEY LIMIT VALUES IS EITHER ZERO, OR GREATER THAN THE
NUMBER OF COLUMNS IN THE KEY OF INDEX ${index-name}
-666 ${stmt-verb} ${object} CANNOT BE EXECUTED BECAUSE ${function} IS IN
PROGRESS
-667 THE CLUSTERING INDEX FOR A PARTITIONED TABLE SPACE CANNOT BE EXPLIC
ITLY DROPPED
-668 THE COLUMN CANNOT BE ADDED TO THE TABLE BECAUSE THE TABLE HAS AN ED
IT PROCEDURE
-669 THE OBJECT CANNOT BE EXPLICITLY DROPPED. REASON ${reason-code}
-670 THE RECORD LENGTH OF THE TABLE EXCEEDS THE PAGE SIZE LIMIT
-671 THE BUFFERPOOL ATTRIBUTE OF THE TABLE SPACE CANNOT BE ALTERED AS SP
ECIFIED BECAUSE IT WOULD CHANGE THE PAGE SIZE OF THE TABLE SPACE
-672 OPERATION DROP NOT ALLOWED ON TABLE ${table}_${name}
-677 INSUFFICIENT VIRTUAL STORAGE FOR BUFFERPOOL EXPANSION
-679 THE OBJECT ${name} CANNOT BE CREATED BECAUSE A DROP IS PENDING ON T
HE OBJECT
-680 TOO MANY COLUMNS SPECIFIED FOR A TABLE, VIEW OR TABLE FUNCTION
-681 COLUMN ${column-name} IN VIOLATION OF INSTALLATION DEFINED FIELD PR
OCEDURE. RT: ${return-code}, RS: ${reason-code}, MSG: ${message-token}
-682 FIELD PROCEDURE ${procedure-name} COULD NOT BE LOADED
-683 THE SPECIFICATION FOR COLUMN, DISTINCT TYPE, FUNCTION, OR PROCEDURE
${data-item} CONTAINS INCOMPATIBLE CLAUSES
-685 INVALID FIELD TYPE, ${column-name}
-686 COLUMN DEFINED WITH A FIELD PROCEDURE CAN NOT COMPARE WITH ANOTHER
COLUMN WITH DIFFERENT FIELD PROCEDURE
-687 FIELD TYPES INCOMPARABLE
-688 INCORRECT DATA RETURNED FROM FIELD PROCEDURE, ${column-name}, ${msg
no}
-689 TOO MANY COLUMNS DEFINED FOR A DEPENDENT TABLE
-690 THE STATEMENT IS REJECTED BY DATA DEFINITION CONTROL SUPPORT. REASO
N ${reason-code}
-691 THE REQUIRED REGISTRATION TABLE ${table-name} DOES NOT EXIST
-692 THE REQUIRED UNIQUE INDEX ${index-name} FOR DDL REGISTRATION TABLE
${table-name} DOES NOT EXIST
-696 THE DEFINITION OF TRIGGER ${trigger-name} INCLUDES AN INVALID USE O
F CORRELATION NAME OR TRANSITION TABLE NAME ${name}. REASON CODE=${rea
son-code}
-697 OLD OR NEW CORRELATION NAMES ARE NOT ALLOWED IN A TRIGGER DEFINED W
ITH THE FOR EACH STATEMENT CLAUSE. OLD_TABLE OR NEW_TABLE NAMES ARE NO
T ALLOWED IN A TRIGGER WITH THE BEFORE CLAUSE.
-715 PROGRAM ${program-name} WITH MARK ${release-dependency-mark} FAILED
BECAUSE IT DEPENDS ON FUNCTIONS OF THE RELEASE FROM WHICH FALLBACK HA
S OCCURRED
-716 PROGRAM ${program-name} PRECOMPILED WITH INCORRECT LEVEL FOR THIS R
ELEASE
-717 ${bind-type} FOR ${object-type} ${object-name} WITH MARK ${release-
dependency-mark} FAILED BECAUSE ${object-type} DEPENDS ON FUNCTIONS OF
THE RELEASE FROM WHICH FALLBACK HAS OCCURRED
-718 REBIND OF PACKAGE ${package-name} FAILED BECAUSE IBMREQD OF ${ibmre
qd} IS INVALID
-719 BIND ADD ERROR USING ${auth-id} AUTHORITY PACKAGE ${package-name} A
LREADY EXISTS
-720 BIND ERROR, ATTEMPTING TO REPLACE PACKAGE = ${package}_${name} WITH
VERSION = ${version2} BUT THIS VERSION ALREADY EXISTS
-721 BIND ERROR FOR PACKAGE = ${pkg-id} CONTOKEN = ${contoken} X IS NOT
UNIQUE SO IT CANNOT BE CREATED
-722 ${bind-type} ERROR USING ${auth-id} AUTHORITY PACKAGE ${package-nam
e} DOES NOT EXIST
-723 AN ERROR OCCURRED IN A TRIGGERED SQL STATEMENT IN ${trigger-name}.
INFORMATION RETURNED: SQLCODE: ${sqlerror}, SQLSTATE: ${sqlstate}, MES
SAGE TOKENS ${token-list}, SECTION NUMBER ${section-number}
-724 THE ACTIVATION OF THE ${object-type} OBJECT ${object-name} WOULD EX
CEED THE MAXIMUM LEVEL OF INDIRECT SQL CASCADING
-725 THE SPECIAL REGISTER ${register} AT LOCATION ${location} WAS SUPPLI
ED AN INVALID VALUE
-726 BIND ERROR ATTEMPTING TO REPLACE PACKAGE = ${package-name}. THERE A
RE ENABLE OR DISABLE ENTRIES CURRENTLY ASSOCIATED WITH THE PACKAGE
-728 DATA TYPE ${data-type} IS NOT ALLOWED IN DB2 PRIVATE PROTOCOL PROCE
SSING
-729 A STORED PROCEDURE SPECIFYING COMMIT ON RETURN CANNOT BE THE TARGET
OF A NESTED CALL STATEMENT
-730 THE PARENT OF A TABLE IN A READ-ONLY SHARED DATABASE MUST ALSO BE A
TABLE IN A READ-ONLY SHARED DATABASE
-731 USER-DEFINED DATASET ${dsname} MUST BE DEFINED WITH SHAREOPTIONS(1,
3)
-732 THE DATABASE IS DEFINED ON THIS SUBSYSTEM WITH THE ROSHARE READ ATT
RIBUTE BUT THE TABLE SPACE OR INDEX SPACE HAS NOT BEEN DEFINED ON THE
OWNING SUBSYSTEM
-733 THE DESCRIPTION OF A TABLE SPACE, INDEX SPACE, OR TABLE IN A ROSHAR
E READ DATABASE MUST BE CONSISTENT WITH ITS DESCRIPTION IN THE OWNER S
YSTEM
-734 THE ROSHARE ATTRIBUTE OF A DATABASE CANNOT BE ALTERED FROM ROSHARE
READ
-735 DATABASE ${dbid} CANNOT BE ACCESSED BECAUSE IT IS NO LONGER A SHARE
D DATABASE
-736 INVALID OBID ${obid} SPECIFIED
-737 IMPLICIT TABLE SPACE NOT ALLOWED
-739 CREATE OR ALTER FUNCTION ${function-name} FAILED BECAUSE FUNCTIONS
CANNOT MODIFY DATA WHEN THEY ARE PROCESSED IN PARALLEL.
-740 FUNCTION ${name} IS DEFINED WITH THE OPTION MODIFIES SQL DATA WHICH
IS NOT VALID IN THE CONTEXT IN WHICH IT WAS INVOKED
-741 A ${database-type} DATABASE IS ALREADY DEFINED FOR MEMBER ${member-
name}
-742 DSNDB07 IS THE IMPLICIT WORK FILE DATABASE
-746 THE SQL STATEMENT IN AN EXTERNAL FUNCTION, TRIGGER, OR IN STORED PR
OCEDURE ${name} VIOLATES THE NESTING SQL RESTRICTION
-747 TABLE ${table-name} IS NOT AVAILABLE UNTIL THE AUXILIARY TABLES AND
INDEXES FOR ITS EXTERNALLY STORED COLUMNS HAVE BEEN CREATED
-751 ${object-type} ${object-name} (SPECIFIC NAME ${specific} ${name}) A
TTEMPTED TO EXECUTE AN SQL STATEMENT ${statement} THAT IS NOT ALLOWED
-752 THE CONNECT STATEMENT IS INVALID BECAUSE THE PROCESS IS NOT IN THE
CONNECTABLE STATE
-763 INVALID TABLE SPACE NAME ${table-space-name}
-764 A LOB TABLE SPACE AND ITS ASSOCIATED BASE TABLE SPACE MUST BE IN TH
E SAME DATABASE
-765 TABLE IS NOT COMPATIBLE WITH DATABASE
-766 THE OBJECT OF A STATEMENT IS AN AUXILIARY TABLE FOR WHICH THE REQUE
STED OPERATION IS NOT PERMITTED
-767 MISSING OR INVALID COLUMN SPECIFICATION FOR INDEX ${index-name}
-768 AN AUXILIARY TABLE ALREADY EXISTS FOR THE SPECIFIED COLUMN OR PARTI
TION
-769 SPECIFICATION OF CREATE AUX TABLE DOES NOT MATCH THE CHARACTERISTIC
S OF THE BASE TABLE
-771 INVALID SPECIFICATION OF A ROWID COLUMN
-772 ATTEMPTED TO CAST AN INVALID VALUE TO A ROW ID TYPE
-802 EXCEPTION ERROR ${exception-type} HAS OCCURRED DURING ${operation-t
ype} OPERATION ON ${data-type} DATA, POSITION ${position-number}
-804 AN ERROR WAS FOUND IN THE APPLICATION PROGRAM INPUT PARAMETERS FOR
THE SQL STATEMENT, REASON ${reason}
-805 DBRM OR PACKAGE NAME ${location-name.collection-id.dbrm-name.consis
tency-token} NOT FOUND IN PLAN ${plan-name}. REASON ${reason}
-807 ACCESS DENIED: PACKAGE ${package-name} IS NOT ENABLED FOR ACCESS FR
OM ${connection-type} ${connection-name}
-808 THE CONNECT STATEMENT IS NOT CONSISTENT WITH THE FIRST CONNECT STAT
EMENT
-811 THE RESULT OF AN EMBEDDED SELECT STATEMENT OR A SUBSELECT IN THE SE
T CLAUSE OF AN UPDATE STATEMENT IS A TABLE OF MORE THAN ONE ROW, OR TH
E RESULT OF A SUBQUERY OF A BASIC PREDICATE IS MORE THAN ONE VALUE
-812 THE SQL STATEMENT CANNOT BE PROCESSED BECAUSE A BLANK COLLECTION-ID
WAS FOUND IN THE CURRENT PACKAGESET SPECIAL REGISTER WHILE TRYING TO
FORM A QUALIFIED PACKAGE NAME FOR PROGRAM ${program-name.consistency-t
oken} USING PLAN ${plan-name}
-815 A GROUP BY OR HAVING CLAUSE IS IMPLICITLY OR EXPLICITLY SPECIFIED I
N A SUBSELECT OF A BASIC PREDICATE OR THE SET CLAUSE OF AN UPDATE STAT
EMENT
-817 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE STATEMENT WILL RES
ULT IN A PROHIBITED UPDATE OPERATION.
-818 THE PRECOMPILER-GENERATED TIMESTAMP ${x} IN THE LOAD MODULE IS DIFF
ERENT FROM THE BIND TIMESTAMP ${y} BUILT FROM THE DBRM ${z}
-819 THE VIEW CANNOT BE PROCESSED BECAUSE THE LENGTH OF ITS PARSE TREE I
N THE CATALOG IS ZERO
-820 THE SQL STATEMENT CANNOT BE PROCESSED BECAUSE ${catalog-table} CONT
AINS A VALUE THAT IS NOT VALID IN THIS RELEASE
-822 THE SQLDA CONTAINS AN INVALID DATA ADDRESS OR INDICATOR VARIABLE AD
DRESS
-840 TOO MANY ITEMS RETURNED IN A SELECT OR INSERT LIST
-842 A CONNECTION TO ${location-name} ALREADY EXISTS
-843 THE SET CONNECTION OR RELEASE STATEMENT MUST SPECIFY AN EXISTING CO
NNECTION
-846 INVALID SPECIFICATION OF AN IDENTITY COLUMN OR SEQUENCE OBJECT ${ob
ject}_${type} ${object}_${name}. REASON CODE = ${reason}_${code}
-867 INVALID SPECIFICATION OF A ROWID COLUMN
-870 THE NUMBER OF HOST VARIABLES IN THE STATEMENT IS NOT EQUAL TO THE N
UMBER OF DESCRIPTORS
-872 A VALID CCSID HAS NOT YET BEEN SPECIFIED FOR THIS SUBSYSTEM
-874 THE ENCODING SCHEME SPECIFIED FOR THE ${object-type} MUST BE THE SA
ME AS THE CONTAINING TABLE SPACE OR OTHER PARAMETERS
-875 ${operand} CANNOT BE USED WITH THE ASCII DATA REFERENCED
-877 CCSID ASCII OR CCSID UNICODE IS NOT ALLOWED FOR THIS DATABASE OR TA
BLE SPACE
-879 CREATE ${or} ALTER STATEMENT FOR ${obj-name} CANNOT DEFINE A COLUMN
, DISTINCT TYPE, FUNCTION OR STORED PROCEDURE PARAMETER AS MIXED OR GR
APHIC WITH ENCODING SCHEME ${encoding-scheme}
-880 SAVEPOINT ${savepoint-name} DOES NOT EXIST OR IS INVALID IN THIS CO
NTEXT
-881 A SAVEPOINT WITH NAME ${savepoint-name} ALREADY EXISTS, BUT THIS SA
VEPOINT NAME CANNOT BE REUSED
-882 SAVEPOINT DOES NOT EXIST
-901 UNSUCCESSFUL EXECUTION CAUSED BY A SYSTEM ERROR THAT DOES NOT PRECL
UDE THE SUCCESSFUL EXECUTION OF SUBSEQUENT SQL STATEMENTS
-902 POINTER TO THE ESSENTIAL CONTROL BLOCK (CT/RDA) HAS VALUE 0, REBIND
REQUIRED
-904 UNSUCCESSFUL EXECUTION CAUSED BY AN UNAVAILABLE RESOURCE. REASON ${
reason-code}, TYPE OF RESOURCE ${resource-type}, AND RESOURCE NAME ${r
esource-name}
-905 UNSUCCESSFUL EXECUTION DUE TO RESOURCE LIMIT BEING EXCEEDED, RESOUR
CE NAME = ${resource-name} LIMIT = ${limit-amount1} CPU SECONDS (${lim
it-amount2} SERVICE UNITS) DERIVED FROM ${limit-source}
-906 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THIS FUNCTION IS DISAB
LED DUE TO A PRIOR ERROR
-908 ${bind-type} ERROR USING ${auth-id} AUTHORITY. BIND, REBIND OR AUTO
-REBIND OPERATION IS NOT ALLOWED
-909 THE OBJECT HAS BEEN DELETED
-911 THE CURRENT UNIT OF WORK HAS BEEN ROLLED BACK DUE TO DEADLOCK OR TI
MEOUT. REASON ${reason-code}, TYPE OF RESOURCE ${resource-type}, AND R
ESOURCE NAME ${resource-name}
-913 UNSUCCESSFUL EXECUTION CAUSED BY DEADLOCK OR TIMEOUT. REASON CODE $
{reason-code}, TYPE OF RESOURCE ${resource-type}, AND RESOURCE NAME ${
resource-name}
-917 BIND PACKAGE FAILED
-918 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE A CONNECTION HAS BEEN
LOST
-919 A ROLLBACK OPERATION IS REQUIRED
-922 AUTHORIZATION FAILURE: ${error-type} ERROR. REASON ${reason-code}
-923 CONNECTION NOT ESTABLISHED: DB2 ${condition} REASON ${reason-code},
TYPE ${resource-type}, NAME ${resource-name}
-924 DB2 CONNECTION INTERNAL ERROR, ${function-code}, ${return-code}, ${
reason-code}
-925 COMMIT NOT VALID IN IMS, CICS OR RRSAF ENVIRONMENT
-926 ROLLBACK NOT VALID IN IMS, CICS OR RRSAF ENVIRONMENT
-927 THE LANGUAGE INTERFACE (LI) WAS CALLED WHEN THE CONNECTING ENVIRONM
ENT WAS NOT ESTABLISHED. THE PROGRAM SHOULD BE INVOKED UNDER THE DSN C
OMMAND
-929 FAILURE IN A DATA CAPTURE EXIT: ${token}
-939 ROLLBACK REQUIRED DUE TO UNREQUESTED ROLLBACK OF A REMOTE SERVER
-947 THE SQL STATEMENT FAILED BECAUSE IT WILL CHANGE A TABLE DEFINED WIT
H DATA CAPTURE CHANGES, BUT THE DATA CANNOT BE PROPAGATED
-948 DISTRIBUTED OPERATION IS INVALID
-950 THE LOCATION NAME SPECIFIED IN THE CONNECT STATEMENT IS INVALID OR
NOT LISTED IN THE COMMUNICATIONS DATABASE
-952 PROCESSING WAS INTERRUPTED BY A CANCEL REQUEST FROM A CLIENT PROGRA
M
-965 STORED PROCEDURE OR FUNCTION ${name} TERMINATED ABNORMALLY
-981 THE SQL STATEMENT FAILED BECAUSE THE RRSAF CONNECTION IS NOT IN A S
TATE THAT ALLOWS SQL OPERATIONS, REASON ${reason-code}.
-991 CALL ATTACH WAS UNABLE TO ESTABLISH AN IMPLICIT CONNECT OR OPEN TO
DB2. RC1= ${rc1} RC2= ${rc2}
-1760 CREATE PROCEDURE FOR ${procedure-name} MUST HAVE VALID LANGUAGE AN
D EXTERNAL CLAUSES
-2001 THE NUMBER OF HOST VARIABLE PARAMETERS FOR A STORED PROCEDURE IS N
OT EQUAL TO THE NUMBER OF EXPECTED HOST VARIABLE PARAMETERS. ACTUAL NU
MBER ${sqldanum}, EXPECTED NUMBER ${opnum}
-4700 ATTEMPT TO USE NEW FUNCTION BEFORE NEW FUNCTION MODE
-20003 GBPCACHE NONE CANNOT BE SPECIFIED FOR TABLESPACE OR INDEX IN GREC
P
-20004 8K ${or} 16K BUFFERPOOL PAGESIZE INVALID FOR A WORKFILE OBJECT
-20005 THE INTERNAL ID LIMIT OF ${limit} HAS BEEN EXCEEDED FOR OBJECT TY
PE ${object-type}
-20008 UNSUPPORTED OPTION ${keyword} SPECIFIED
-20058 THE FULLSELECT SPECIFIED FOR MATERIALIZED QUERY TABLE ${table-nam
e} IS NOT VALID.
-20070 AUXILIARY TABLE ${table-name} CANNOT BE CREATED BECAUSE COLUMN ${
column-name} IS NOT A LOB COLUMN
-20071 WLM ENVIRONMENT NAME MUST BE SPECIFIED ${function-name}
-20073 THE FUNCTION ${function-name} CANNOT BE ALTERED BECAUSE IT IS REF
ERENCED IN EXISTING VIEW OR MATERIALIZED QUERY TABLE DEFINITIONS
-20074 THE OBJECT ${object-name} CANNOT BE CREATED BECAUSE THE FIRST THR
EE CHARACTERS ARE RESERVED FOR SYSTEM OBJECTS
-20091 A VIEW NAME WAS SPECIFIED AFTER LIKE IN ADDITION TO THE INCLUDING
IDENTITY COLUMN ATTRIBUTES CLAUSE
-20093 THE TABLE ${table-name} CANNOT BE CONVERTED TO OR FROM A MATERIAL
IZED QUERY TABLE, OR THE MATERIALIZED QUERY TABLE PROPERTY CANNOT BE A
LTERED. REASON CODE = ${reason-code}.
-20100 AN ERROR OCCURRED WHEN BINDING A TRIGGERED SQL STATEMENT. INFORMA
TION RETURNED: SECTION NUMBER : ${section-number} SQLCODE ${sqlerror},
SQLSTATE ${sqlstate}, AND MESSAGE TOKENS ${token-list}
-20101 THE FUNCTION ${function} FAILED WITH REASON ${rc}
-20102 CREATE OR ALTER STATEMENT FOR ROUTINE ${routine-name} SPECIFIED T
HE ${option} OPTION WHICH IS NOT ALLOWED FOR THE TYPE OF ROUTINE
-20104 AN ATTEMPT TO ALTER A CCSID FROM ${from-ccsid} TO ${to-ccsid} FAI
LED
-20107 HOST VARIABLE OR PARAMETER NUMBER ${position-number} CANNOT BE US
ED AS SPECIFIED BECAUSE REASON ${reason}
-20108 A RESULT SET CONTAINS AN UNSUPPORTED DATA TYPE IN POSITION NUMBER
${position-number} FOR CURSOR ${cursor-name} OPENED BY STORED PROCEDU
RE ${procedure-name}
-20110 CANNOT IMPLICITLY CONNECT TO A REMOTE SITE WITH A SAVEPOINT OUTST
ANDING
-20111 CANNOT ISSUE SAVEPOINT, RELEASE SAVEPOINT, ROLLBACK TO SAVEPOINT
FROM A TRIGGER, FROM A USER-DEFINED FUNCTION, OR FROM A GLOBAL TRANSAC
TION
-20123 CALL TO STORED PROCEDURE ${procedure} FAILED BECAUSE THE RESULT S
ET RETURNED FOR CURSOR ${cursor} IS SCROLLABLE, BUT THE CURSOR IS NOT
POSITIONED BEFORE THE FIRST ROW
-20124 OPEN CURSOR ${cursor} FAILED BECAUSE THE CURSOR IS SCROLLABLE BUT
THE CLIENT DOES NOT SUPPORT THIS
-20125 CALL TO STORED PROCEDURE ${procedure} FAILED BECAUSE THE RESULT S
ET FOR CURSOR ${cursor} IS SCROLLABLE, BUT THE CLIENT DOES NOT SUPPORT
THIS
-20126 CURSOR ${cursor} IS DEFINED AS SCROLLABLE, BUT THE ENVIRONMENT IN
VOLVES A HOP SITE
-20127 VALUE SPECIFIED ON FETCH STATEMENT FOR ABSOLUTE OR RELATIVE IS TO
O LARGE FOR DRDA
-20129 LOCAL SPECIAL REGISTER IS NOT VALID AS USED
-20142 SEQUENCE ${sequence-name} CANNOT BE USED AS SPECIFIED
-20163 HEXADECIMAL CONSTANT GX IS NOT ALLOWED
-20164 SENSITIVE CURSOR ${cursor-name} IS DEFINED FOR A SELECT STATEMENT
CONTAINING AN INSERT STATEMENT
-20174 ALTER TABLE STATEMENT FOR ${table-name} SPECIFIED A PRECISION AND
SCALE THAT IS NOT AS LARGE AS THE EXISTING PRECISION AND SCALE
-20177 SET DATA TYPE CLAUSE ON ALTER TABLE SPECIFIED FLOATING POINT, BUT
THIS CHANGE IS DISALLOWED
-20180 COLUMN ${column-name} IN TABLE ${table-name} CANNOT BE ALTERED AS
SPECIFIED
-20181 COLUMN CANNOT BE ADDED TO INDEX ${index-name}
-20185 CURSOR ${cursor-name} IS NOT DEFINED TO ACCESS ROWSETS, BUT A CLA
USE WAS SPECIFIED THAT IS VALID ONLY WITH ROWSET ACCESS
-20203 USER-DEFINED FUNCTION OR PROCEDURE ${name} HAS A JAVA METHOD WITH
AN INVALID SIGNATURE. THE ERROR IS AT OR NEAR PARAMETER ${number}. TH
E SIGNATURE IS ${signature}.
-20204 THE USER-DEFINED FUNCTION OR PROCEDURE ${routine-name} WAS UNABLE
TO MAP TO A SINGLE JAVA METHOD
-20207 THE INSTALL OR REMOVE OF ${jar-name} SPECIFIED THE USE OF A DEPLO
YMENT DESCRIPTOR.
-20227 REQUIRED CLAUSE IS MISSING FOR ARGUMENT ${number} OF ${expression
}
-20276 The XML NAMESPACE PREFIX ${xml-namespace-prefix} IS NOT VALID. RE
ASON CODE = ${reason-code}.
-30000 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT WILL N
OT AFFECT THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATE
MENTS: REASON ${reason-code} (${sub-code})
-30002 THE SQL STATEMENT CANNOT BE EXECUTED DUE TO A PRIOR CONDITION IN
A CHAIN OF STATEMENTS
-30021 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT WILL A
FFECT THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATEMENT
S: MANAGER ${manager} AT LEVEL ${level} NOT SUPPORTED ERROR
-30030 COMMIT REQUEST WAS UNSUCCESSFUL, A DISTRIBUTION PROTOCOL VIOLATIO
N HAS BEEN DETECTED, THE CONVERSATION HAS BEEN DEALLOCATED. ORIGINAL S
QLCODE=${original-sqlcode} AND ORIGINAL SQLSTATE=${original-sqlstate}
-30040 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL NOT AFFEC
T THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATEMENTS. R
EASON ${reason-code} TYPE OF RESOURCE ${resource-type} RESOURCE NAME $
{resource-name} PRODUCT ID ${pppvvrrm} RDBNAME ${rdbname}
-30051 BIND PROCESS WITH SPECIFIED PACKAGE NAME AND CONSISTENCY TOKEN NO
T ACTIVE
-30052 PROGRAM PREPARATION ASSUMPTIONS ARE INCORRECT
-30053 OWNER AUTHORIZATION FAILURE
-30060 RDB AUTHORIZATION FAILURE
-30061 RDB NOT FOUND
-30070 ${command} COMMAND NOT SUPPORTED ERROR
-30071 ${object-type} OBJECT NOT SUPPORTED ERROR
-30072 ${parameter} ${subcode} PARAMETER NOT SUPPORTED ERROR
-30073 ${parameter} ${subcode} PARAMETER VALUE NOT SUPPORTED ERROR
-30074 REPLY MESSAGE WITH ${codepoint} (${svrcod}) NOT SUPPORTED ERROR
-30080 COMMUNICATION ERROR ${code} (${subcode})
-30082 CONNECTION FAILED FOR SECURITY REASON ${reason-code} (${reason-st
ring})
-30090 REMOTE OPERATION INVALID FOR APPLICATION EXECUTION ENVIRONMENT
-30104 ERROR IN BIND OPTION ${option} AND BIND VALUE ${value}.
-30105 BIND OPTION ${option1} IS NOT ALLOWED WITH BIND OPTION ${option2}
-30106 INVALID INPUT DATA DETECTED FOR A MULTIPLE ROW INSERT OPERATION.
INSERT PROCESSING IS TERMINATED
>>>>> sqlCodes V8 V9 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
/*<<< sqlCodes V8 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
OR ANY TABLE IDENTIFIED IN A FROM CLAUSE
+231 CURRENT POSITION OF CURSOR ${cursor-name} IS NOT VALID FOR FETCH OF
THE CURRENT ROW
+237 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE @ RE
QUIRED BECAUSE AT LEAST ONE OF THE COLUMNS BEING DESCRIBED IS A DISTIN
CT TYPE
+331 THE NULL VALUE HAS BEEN ASSIGNED TO A HOST VARIABLE BECAUSE THE STR
ING CANNOT BE TRANSLATED. REASON ${reason-code}, CHARACTER ${code-poin
t}, HOST VARIABLE ${position-number}
+394 USER SPECIFIED OPTIMIZATION HINTS USED DURING ACCESS PATH SELECTION
+395 USER SPECIFIED OPTIMIZATION HINTS ARE INVALID (REASON CODE = ${reas
on-code}). THE OPTIMIZATION HINTS ARE IGNORED.
+434 OPTION ${keyword} IS A DEPRECATED FEATURE
+585 THE COLLECTION ${collectoin-id} APPEARS MORE THAN ONCE IN THE SET $
{special-register}
+645 WHERE NOT NULL IS IGNORED BECAUSE THE INDEX KEY CANNOT CONTAIN NULL
VALUES
+664 THE INTERNAL LENGTH OF THE LIMIT-KEY FIELDS FOR THE PARTITIONED IND
EX ${index-name} EXCEEDS THE LENGTH IMPOSED BY DB2
+20002 THE GBPCACHE SPECIFICATION IS IGNORED, ${bpname} DOES NOT ALLOW C
ACHING
+20007 USE OF OPTIMIZATION HINTS IS DISALLOWED BY A DB2 SUBSYSTEM PARAME
TER. THE SPECIAL REGISTER OPTIMIZATION HINT IS SET TO THE DEFAULT VA
LUE OF BLANKS.
+30100 OPERATION COMPLETED SUCCESSFULLY BUT A DISTRIBUTION PROTOCOL VIOL
ATION HAS BEEN DETECTED. ORIGINAL SQLCODE=${original-sqlcode} AND ORIG
INAL SQLSTATE=${original-sqlstate}
-079 QUALIFIER FOR DECLARED GLOBAL TEMPORARY TABLE ${table-name} MUST BE
SESSION, NOT ${qualifier}
-102 LITERAL STRING IS TOO LONG. STRING BEGINS ${string}
-103 ${literal} IS AN INVALID NUMERIC LITERAL
-110 INVALID HEXADECIMAL LITERAL BEGINNING ${string}
-112 THE OPERAND OF A AGGREGATE FUNCTION INCLUDES A AGGREGATE FUNCTION O
R A SCALAR FULLSELECT
-113 INVALID CHARACTER FOUND IN ${string}, REASON CODE ${nnn}
-119 A COLUMN IDENTIFIED IN A HAVING CLAUSE IS NOT INCLUDED IN THE GROUP
BY CLAUSE
-120 AN AGGREGATE FUNCTION IS NOT VALID IN THE CONTEXT IN WHICH IT WAS I
NVOKED
-121 THE COLUMN ${name} IS IDENTIFIED MORE THAN ONCE IN THE INSERT OR UP
DATE OR SET TRANSITION VARIABLE STATEMENT
-122 A SELECT STATEMENT WITH NO GROUP BY CLAUSE CONTAINS A COLUMN NAME A
ND A${n} AGGREGATE FUNCTION IN THE SELECT CLAUSE OR A COLUMN NAME IS C
ONTAINED IN THE SELECT CLAUSE BUT NOT IN THE GROUP BY CLAUSE
-134 IMPROPER USE OF LONG STRING COLUMN ${column-name} OR AN EXPRESSION
THAT RESOLVES TO A LONG STRING
-136 SORT CANNOT BE EXECUTED BECAUSE THE SORT KEY LENGTH IS GREATER THAN
4000 BYTES
-138 THE SECOND OR THIRD ARGUMENT OF THE SUBSTR FUNCTION IS OUT OF RANGE
-147 ALTER FUNCTION ${function-name} FAILED BECAUSE SOURCE FUNCTIONS CAN
NOT BE ALTERED
-148 THE SOURCE TABLE ${source-name} CANNOT BE RENAMED OR ALTERED
-150 THE OBJECT OF THE INSERT, DELETE, OR UPDATE STATEMENT IS A VIEW, SY
STEM-MAINTAINED MATERIALIZED QUERY TABLE, OR TRANSITION TABLE FOR WHIC
H THE REQUESTED OPERATION IS NOT PERMITTED
-151 THE UPDATE STATEMENT IS INVALID BECAUSE THE CATALOG DESCRIPTION OF
COLUMN ${column-name} INDICATES THAT IT CANNOT BE UPDATED
-159 THE STATEMENT REFERENCES ${object-name} WHICH IDENTIFIES A(N) ${obj
ect-type1} RATHER THAN A(N) ${object-type2}
-160 THE WITH CHECK OPTION CANNOT BE USED FOR THE SPECIFIED VIEW
-187 A REFERENCE TO A CURRENT DATE/TIME SPECIAL REGISTER IS INVALID BECA
USE THE MVS TOD CLOCK IS BAD OR THE MVS PARMTZ IS OUT OF RANGE
-189 CCSID ${ccsid} IS UNKNOWN OR INVALID FOR THE DATA TYPE OR SUBTYPE
-190 THE ATTRIBUTES SPECIFIED FOR THE OF COLUMN ${table-name.column-name
} ARE NOT COMPATIBLE WITH THE EXISTING COLUMN
-197 QUALIFIED COLUMN NAMES IN ORDER BY CLAUSE NOT PERMITTED WHEN UNION
OR UNION ALL SPECIFIED
-206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
OR ANY TABLE IDENTIFIED IN A FROM CLAUSE, OR IS NOT A COLUMN OF THE T
RIGGERING TABLE OF A TRIGGER
-222 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST A HOLE USING ${
cursor-name}
-225 FETCH STATEMENT FOR ${cursor-name} IS NOT VALID BECAUSE THE CURSOR
IS NOT DEFINED AS SCROLL
-229 THE LOCALE ${locale} SPECIFIED IN A SET LOCALE OR OTHER STATEMENT T
HAT IS LOCALE SENSITIVE WAS NOT FOUND
-240 THE PART CLAUSE OF A LOCK TABLE STATEMENT IS INVALID
-242 THE OBJECT NAMED ${object-name} OF TYPE ${object-type} WAS SPECIFIE
D MORE THAN ONCE IN THE LIST OF OBJECTS.
-245 THE INVOCATION OF FUNCTION ROUTINE-NAME IS AMBIGUOUS
-312 ${variable-name} IS AN UNDEFINED OR UNUSABLE HOST VARIABLE OR IS US
ED IN A DYNAMIC SQL STATEMENT OR A TRIGGER DEFINITION
-330 A STRING CANNOT BE USED BECAUSE IT CANNOT BE TRANSLATED. REASON ${r
eason-code}, CHARACTER ${code-point}, HOST VARIABLE ${position-number}
-331 A STRING CANNOT BE ASSIGNED TO A HOST VARIABLE BECAUSE IT CANNOT BE
TRANSLATED. REASON ${reason-code}, CHARACTER ${code-point}, POSITION
${position-number}
-333 THE SUBTYPE OF A STRING VARIABLE IS NOT THE SAME AS THE SUBTYPE KNO
WN AT BIND TIME AND THE DIFFERENCE CANNOT BE RESOLVED BY TRANSLATION
-336 The decimal number is used in a context where the scale must be zer
o. This can occur when a decimal number is specified in a CREATE or AL
TER SEQUENCE statement for START WITH, INCREMENT BY, MINVALUE, MAXVALU
E, or RESTART WITH.
-342 THE COMMON TABLE EXPRESSION ${name} CANNOT USE SELECT DISTINCT AND
MUST USE UNION ALL BECAUSE IT IS RECURSIVE
-344 THE RECURSIVE COMMON TABLE EXPRESSION ${name} HAS MISMATCHED DATA T
YPES OR LENGTHS FOR COLUMN ${column-name}
-345 THE FULLSELECT OF THE RECURSIVE COMMON TABLE EXPRESSION ${name} MUS
T BE THE UNION OF TWO OR MORE FULLSELECTS AND CANNOT INCLUDE COLUMN FU
NCTIONS, GROUP BY CLAUSE, HAVING CLAUSE, OR AN EXPLICIT JOIN INCLUDING
AN ON CLAUSE
-348 ${sequence-expression} FOR ${sequence-name} CANNOT BE SPECIFIED IN
THIS CONTEXT
-350 INVALID SPECIFICATION OF A LARGE OBJECT COLUMN
-372 ONLY ONE ROWID OR IDENTITY COLUMN IS ALLOWED IN A TABLE
-373 DEFAULT CANNOT BE SPECIFIED FOR IDENTITY COLUMN ${column-name}
-390 THE FUNCTION ${function-name}, SPECIFIC NAME ${specific-name}, IS N
OT VALID IN THE CONTEXT IN WHICH IT OCCURS
-397 THE OPTION GENERATED IS SPECIFIED WITH A COLUMN THAT IS NOT A ROW I
D OR DISTINCT TYPE BASED ON A ROW ID
-399 ATTEMPTED TO INSERT AN INVALID VALUE INTO A ROWID COLUMN
-405 THE NUMERIC LITERAL ${literal} CANNOT BE USED AS SPECIFIED BECAUSE
IT IS OUT OF RANGE
-408 THE VALUE IS NOT COMPATIBLE WITH THE DATA TYPE OF ITS TARGET
-410 THE FLOATING POINT LITERAL ${literal} CONTAINS MORE THAN 30 CHARACT
ERS
-415 THE CORRESPONDING COLUMNS, ${column-number}, OF THE OPERANDS OF A U
NION OR A UNION ALL DO NOT HAVE COMPARABLE COLUMN DESCRIPTIONS
-416 AN OPERAND OF A UNION CONTAINS A LONG STRING COLUMN
-421 THE OPERANDS OF A UNION OR UNION ALL DO NOT HAVE THE SAME NUMBER OF
COLUMNS
-435 AN INVALID SQLSTATE ${sqlstate} IS SPECIFIED IN THE FUNCTION RAISE_
ERROR OR IN A SIGNAL SQLSTATE STATEMENT
-440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND
-441 INVALID USE OF DISTINCT OR ALL WITH SCALAR FUNCTION ${function-
name}
-451 THE ${data-item} DEFINITION, IN THE CREATE FUNCTION FOR ${function-
name} CONTAINS DATA TYPE ${type} WHICH IS NOT APPROPRIATE FOR AN EXTER
NAL FUNCTION WRITTEN IN THE GIVEN LANGUAGE
-504 THE CURSOR NAME ${cursor-name} IS NOT DEFINED
-511 THE FOR UPDATE CLAUSE CANNOT BE SPECIFIED BECAUSE THE TABLE DESIGNA
TED BY THE CURSOR CANNOT BE MODIFIED
-516 THE DESCRIBE FOR STATIC STATEMENT DOES NOT IDENTIFY A PREPARED STAT
EMENT
-525 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS IN ERROR AT BIN
D TIME FOR SECTION = ${sectno} PACKAGE = ${pkgname} CONSISTENCY TOKEN
= X'${contoken}'
-526 THE REQUESTED OPERATION OR USAGE DOES NOT APPLY TO ${table} ${type}
TEMPORARY TABLE ${table} ${name}
-532 THE RELATIONSHIP ${constraint-name} RESTRICTS THE DELETION OF ROW W
ITH RID X'${rid-number}'
-553 ${auth-id} SPECIFIED IS NOT ONE OF THE VALID AUTHORIZATION IDS
-554 AN AUTHORIZATION ID CANNOT GRANT A PRIVILEGE TO ITSELF
-555 AN AUTHORIZATION ID CANNOT REVOKE A PRIVILEGE FROM ITSELF
-583 THE USE OF FUNCTION ${function-name} IS INVALID BECAUSE IT IS NOT D
ETERMINISTIC OR HAS AN EXTERNAL ACTION
-585 THE COLLECTION ID ${collection-id} APPEARS MORE THAN ONCE IN THE SE
T ${special-register} STATEMENT
-586 THE TOTAL LENGTH OF THE CURRENT PATH SPECIAL REGISTER CANNOT EXCEED
254 CHARACTERS
-590 PARAMETER NAME ${parameter-name} IS NOT UNIQUE IN THE CREATE FOR RO
UTINE ${routine-name}
-593 NOT NULL MUST BE SPECIFIED FOR ROWID OR DISTINCT TYPE COLUMN ${colu
mn-name}
-601 THE NAME OF THE OBJECT TO BE CREATED OR THE TARGET OF A RENAME STAT
EMENT IS IDENTICAL TO THE EXISTING NAME ${name} OF THE OBJECT TYPE ${o
bj-type}
-602 TOO MANY COLUMNS SPECIFIED IN A CREATE INDEX OR ALTER INDEX STATEME
NT
-612 ${column-name} IS A DUPLICATE COLUMN NAME
-620 KEYWORD ${keyword} IN ${stmt} ${type} STATEMENT IS NOT PERMITTED FO
R A ${space} ${type} SPACE IN THE ${database} ${type} DATABASE
-624 TABLE ${table-name} ALREADY HAS A PRIMARY KEY OR UNIQUE KEY CONSTRA
INT WITH SPECIFIED COLUMNS
-627 THE ALTER STATEMENT IS INVALID BECAUSE THE PAGESET HAS USER-MANAGED
DATA SETS
-636 THE PARTITIONING KEYS FOR PARTITION ${part-num} ARE NOT SPECIFIED I
N ASCENDING OR DESCENDING ORDER
-637 DUPLICATE ${keyword} KEYWORD
-643 CHECK CONSTRAINT EXCEEDS MAXIMUM ALLOWABLE LENGTH
-644 INVALID VALUE SPECIFIED FOR KEYWORD ${keyword} IN ${stmt-type} STAT
EMENT
-647 BUFFERPOOL ${bp-name} CANNOT BE SPECIFIED BECAUSE IT HAS NOT BEEN A
CTIVATED
-661 INDEX ${index-name} CANNOT BE CREATED ON PARTITIONED TABLE SPACE ${
tspace-name} BECAUSE THE NUMBER OF PART SPECIFICATIONS IS NOT EQUAL TO
THE NUMBER OF PARTITIONS OF THE TABLE SPACE
-662 A PARTITIONED INDEX CANNOT BE CREATED ON A NON-PARTITIONED TABLE SP
ACE ${tspace-name}
-665 THE PART CLAUSE OF AN ALTER STATEMENT IS OMITTED OR INVALID
-676 ONLY A 4K PAGE BUFFERPOOL CAN BE USED FOR AN INDEX
-678 THE LITERAL ${literal} SPECIFIED FOR THE INDEX LIMIT KEY MUST CONFO
RM TO THE DATA TYPE ${data-type} OF THE CORRESPONDING COLUMN ${column-
name}
-684 THE LENGTH OF LITERAL LIST BEGINNING ${string} IS TOO LONG
-693 THE COLUMN ${column-name} IN DDL REGISTRATION TABLE OR INDEX ${tabl
e-name} (${index-name}) IS NOT DEFINED PROPERLY
-694 THE DDL STATEMENT CANNOT BE EXECUTED BECAUSE A DROP IS PENDING ON T
HE DDL REGISTRATION TABLE ${table-name}
-713 THE REPLACEMENT VALUE ${value} FOR ${special-register} IS INVALID
-748 AN INDEX ALREADY EXISTS ON AUXILIARY TABLE ${table-name}
-750 THE SOURCE TABLE ${source-name} CANNOT BE RENAMED BECAUSE IT IS REF
ERENCED IN EXISTING VIEW, MATERIALIZED QUERY TABLE, OR TRIGGER DEFINIT
IONS
-770 TABLE ${table-name} CANNOT HAVE A LOB COLUMN UNLESS IT ALSO HAS A R
OWID COLUMN
-797 ATTEMPT ${to} CREATE TRIGGER ${trigger-name} WITH AN UNSUPPORTED TR
IGGERED SQL STATEMENT
-798 YOU CANNOT INSERT A VALUE INTO A COLUMN THAT IS DEFINED WITH THE OP
TION GENERATED ALWAYS COLUMN ${column-name}
-803 AN INSERTED OR UPDATED VALUE IS INVALID BECAUSE THE INDEX IN INDEX
SPACE ${indexspace-name} CONSTRAINS COLUMNS OF THE TABLE SO NO TWO ROW
S CAN CONTAIN DUPLICATE VALUES IN THOSE COLUMNS. RID OF EXISTING ROW I
S X${rid}
-845 A PREVVAL EXPRESSION CANNOT BE USED BEFORE THE NEXTVAL EXPRESSION G
ENERATES A VALUE IN THE CURRENT SESSION FOR SEQUENCE ${sequence-name}
-873 DATA ENCODED WITH DIFFERENT ENCODING SCHEMES CANNOT BE REFERENCED I
N THE SAME SQL STATEMENT
-876 '${object}' CANNOT BE CREATED, REASON '${reason}'
-878 THE PLAN_TABLE USED FOR EXPLAIN CANNOT BE ASCII OR UNICODE
-900 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE APPLICATION PROCES
S IS NOT CONNECTED TO AN APPLICATION SERVER
-910 THE SQL STATEMENT CANNOT ACCESS AN OBJECT ON WHICH A DROP OR ALTER
IS PENDING
-989 AFTER TRIGGER ${trigger-name} ATTEMPTED TO MODIFY A ROW IN TABLE ${
table-name} THAT WAS INSERTED BY AN INSERT STATEMENT WITHIN A SELECT S
TATEMENT
-1403 THE USERNAME AND/OR PASSQWORD SUPPLIED IS INCORRECT
-4701 :THE COMBINATION OF THE NUMBER OF TABLE SPACE PARTITIONS AND THE C
ORRESPONDING LENGTH OF THE PARTITIONING LIMIT KEY EXCEEDS THE SYSTEM L
IMIT
-4702 TABLE HAS HAD THE MAXIMUM NUMBER OF ALTERS ALLOWED
-4703 THE ALTER TABLE STATEMENT CANNOT BE EXECUTED BECAUSE COLUMN ${name
} ${column} IS MIXED DATA, OR THE DATA TYPE OR LENGTH SPECIFIED DOES N
OT AGREE WITH THE EXISTING DATA TYPE OR LENGTH.
-5011 HOST STRUCTURE ARRAY ${host-structure-array} IS EITHER NOT DEFINED
OR IS NOT USABLE
-5012 HOST VARIABLE ${host-variable} IS NOT EXACT NUMERIC WITH SCALE ZER
O -${skel}
-20006 LOBS CANNOT BE SPECIFIED AS PARAMETERS WHEN NO WLM ENVIRONMENT IS
SPECIFIED
-20072 ${csect-name} ${bind-type} ${bind-subtype} ERROR USING ${auth-id}
AUTHORITY OPERATION IS NOT ALLOWED ON A TRIGGER PACKAGE ${package-nam
e}
-20092 A VIEW WAS SPECIFIED FOR LIKE BUT IT INCLUDES A ROWID COLUMN
-20106 THE CCSID FOR TABLE SPACE OR DATABASE CANNOT BE CHANGED BECAUSE T
HE TABLE SPACE OR DATABASE ALREADY CONTAINS A TABLE THAT IS REFERENCED
IN EXISTING VIEW DEFINITIONS
-20165 INSERT STATEMENT WITHIN A SELECT IS NOT ALLOWED IN THE CONTEXT IN
WHICH IT WAS SPECIFIED
-20166 INSERT STATEMENT WITHIN A SELECT SPECIFIED VIEW ${view-name} WHIC
H IS NOT A SYMMETRIC VIEW
-20182 ${values} PARTITIONING CLAUSE ON ${stmt-type} STATEMENT FOR ${ind
ex-name} IS NOT VALID
-20183 THE PARITIONED, ADD PART, ADD PARTITIONING KEY, OR ALTER PART CLA
USE SPECIFIED ON CREATE OR ALTER FOR ${name} IS NOT VALID
-20186 A CLAUSE WAS SPECIFIED THAT IS NOT VALID FOR THE STATEMENT BEING
PREPARED OR EXECUTED
-20200 THE INSTALL OR REPLACE OF ${jar-id} WITH URL ${url} FAILED DUE TO
REASON ${reason-code} (${reason-string}).
-20201 THE INSTALL, REPLACE OR REMOVE OF ${jar-name} FAILED DUE TO REASO
N ${reason-code} (${reason-string})
-20202 THE REPLACE OR REMOVE OF ${jar-name} FAILED AS ${class} IS IN USE
-20210 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS AT A LEVEL TH
AT IS INCOMPATIBLE WITH THE CURRENT VALUE OF THE ENCODING BIND OPTION
OR SPECIAL REGISTER
-20212 USER-DEFINED ROUTINE ${name} ENCOUNTERED AN EXCEPTION ATTEMPTING
TO LOAD JAVA CLASS ${class-name} FROM JAR ${jar-name}. ORIGINAL EXCEPT
ION: ${exception-string}.
-20213 STORED PROCEDURE ${procedure-name} HAS RETURNED A DYNAMIC RESULT
SET OF AN INVALID CLASS. PARAMETER ${number} IS NOT A DB2 RESULT SET
-20248 ATTEMPTED TO EXPLAIN A CACHED STATEMENT WITH STMTID OR STMTTOKEN
ID-${token} BUT THE REQUIRED EXPLAIN INFORMATION IS NOT ACCESSIBLE.
-20275 The XML NAME ${xml-name} IS NOT VALID. REASON CODE = ${reason-cod
e}.
-30005 EXECUTION FAILED BECAUSE FUNCTION NOT SUPPORTED BY THE SERVER: LO
CATION ${location} PRODUCT ID ${pppvvrr} REASON CODE ${reason-code} ($
{sub-code})
-30020 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT CAUSED
DEALLOCATION OF THE CONVERSATION: REASON <${reason-code} (${sub-code}
)>
-30025 EXECUTION FAILED BECAUSE FUNCTION IS NOT SUPPORTED BY THE SERVER
WHICH CAUSED TERMINATION OF THE CONNETION: LOCATION ${location} PRODUC
T ID ${pppvvrr} REASON CODE ${reason-code} (${sub-code})
-30041 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL AFFECT TH
E SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS AND SQL STATEMENTS. REAS
ON <${reason-code}> TYPE OF RESOURCE <${resource-type}> RESOURCE NAME
<${resource-name}> PRODUCT ID <${pppvvrrm}> RDBNAME <${rdbname}>
-30050 <${command-or-SQL-statement-type} COMMAND OR SQL STATEMENT INVALI
D WHILE BIND PROCESS IN PROGRESS
-30081 ${prot} COMMUNICATION ERROR DETECTED. API=${api}, LOCATION=${loc}
, FUNCTION=${func}, ERROR CODES=${rc1} ${rc2} ${rc3}
>>>>> sqlCodes V8 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
/*<<< sqlCodes V9 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+205 ${column-name} IS NOT A COLUMN OF TABLE ${table-name}
+206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
MERGED TABLE, OR ANY TABLE IDENTIFIED IN A FROM CLAUSE
+231 CURRENT POSITION OF CURSOR ${cursor-name} IS NOT VALID FOR THE SPEC
IFIED FETCH ORIENTATION OF THE CURRENT ROW OR ROWSET
+237 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED BECAUSE AT LEAST ONE OF THE COLUMNS BEING DESCRIBED IS A DISTINCT
TYPE
+252 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY PROCESSED ALL REQU
ESTED ROWS, WITH ONE OR MORE WARNING CONDITIONS
+331 THE NULL VALUE HAS BEEN ASSIGNED TO A HOST VARIABLE OR PARAMETER BE
CAUSE THE STRING CANNOT BE CONVERTED FROM ${source-ccsid} TO ${target-
ccsid}. REASON ${reason-code}, POSITION ${position-number}
+354 A ROWSET FETCH STATEMENT MAY HAVE RETURNED ONE OR MORE ROWS OF DATA
. HOWEVER, ONE OR MORE WARNING CONDITIONS WERE ALSO ENCOUNTERED. USE T
HE GET DIAGNOSTICS STATEMENT FOR MORE INFORMATION REGARDING THE CONDIT
IONS THAT WERE ENCOUNTERED
+361 COMMAND WAS SUCCESSFUL BUT RESULTED IN THE FOLLOWING: ${msg-token}
+364 DECFLOAT EXCEPTION ${exception-type} HAS OCCURRED DURING ${operatio
n-type} OPERATION, POSITION ${position-number}
+385 ASSIGNMENT TO AN SQLSTATE OR SQLCODE VARIABLE IN AN SQL ROUTINE ${r
outine-name} MAY BE OVERWRITTEN AND DOES NOT ACTIVATE ANY HANDLER
+394 ALL USER SPECIFIED OPTIMIZATION HINTS USED DURING ACCESS PATH SELEC
TION
+395 A USER SPECIFIED OPTIMIZATION HINT IS INVALID (REASON CODE = ${reas
on-code})
+434 ${clause} IS A DEPRECATED CLAUSE
+438 APPLICATION RAISED WARNING WITH DIAGNOSTIC TEXT: ${text}
+440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND
+585 THE COLLECTION ${collection-id} APPEARS MORE THAN ONCE WHEN SETTING
THE ${special-register} SPECIAL REGISTER
+645 WHERE NOT NULL IS IGNORED BECAUSE THE INDEX KEY CANNOT CONTAIN NULL
VALUES OR THE INDEX IS AN XML INDEX
+664 THE INTERNAL LENGTH OF THE LIMIT-KEY FIELDS SPECIFIED IN THE PARTIT
ION CLAUSE OF THE ${statement-name} STATEMENT EXCEEDS THE EXISTING INT
ERNAL LIMIT KEY LENGTH STORED IN CATALOG TABLE ${table-name}
+20002 THE ${clause} SPECIFICATION IS IGNORED FOR OBJECT ${object-name}
+20007 USE OF OPTIMIZATION HINTS IS DISALLOWED BY A DB2 SUBSYSTEM PARAME
TER. THE SPECIAL REGISTER OPTIMIZATION HINT IS SET TO AN EMPTY STRIN
G.
+20141 TRUNCATION OF VALUE WITH LENGTH ${length} OCCURRED FOR ${hv-or-pa
rm-number}
+20187 ROLLBACK TO SAVEPOINT CAUSED A NOT LOGGED TABLE SPACE TO BE PLACE
D IN THE LPL
+20237 FETCH PRIOR ROWSET FOR CURSOR ${cursor-name} RETURNED A PARTIAL R
OWSET
+20245 NOT PADDED CLAUSE IS IGNORED FOR INDEXES CREATED ON AUXILIARY TAB
LES
+20270 OPTION NOT SPECIFIED FOLLOWING ALTER PARTITION CLAUSE
+20272 TABLE SPACE ${table-space-name} HAS BEEN CONVERTED TO USE TABLE-C
ONTROLLED PARTITIONING INSTEAD OF INDEX-CONTROLLED PARTITIONING, ADDIT
IONAL INFORMATION: ${old-limit-key-value}
+20348 THE PATH VALUE HAS BEEN TRUNCATED.
+20360 TRUSTED CONNECTION CAN NOT BE ESTABLISHED FOR SYSTEM AUTHID ${aut
horization-name}
+20365 A SIGNALING NAN WAS ENCOUNTERED, OR AN EXCEPTION OCCURRED IN AN A
RITHMETIC OPERATION OR FUNCTION INVOLVING A DECFLOAT.
+20367 OPTION ${clause} IS NOT SUPPORTED IN THE CONTEXT IN WHICH IT WAS
SPECIFIED
+20368 TRUSTED CONTEXT ${context-name} IS NO LONGER DEFINED TO BE USED B
Y SPECIFIC VALUES FOR ATTRIBUTE ${attribute-name}
+20371 THE ABILITY TO USE TRUSTED CONTEXT ${context-name} WAS REMOVED FR
OM SOME, BUT NOT ALL AUTHORIZATION IDS SPECIFIED IN THE STATEMENT.
+20378 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY COMPLETED FOR SO
ME OF THE REQUESTED ROWS, POSSIBLY WITH WARNINGS, AND ONE OR MORE ERRO
RS, AND THE CURSOR CAN BE USED
+30100 OPERATION COMPLETED SUCCESSFULLY BUT A DISTRIBUTION PROTOCOL VIOL
ATION HAS BEEN DETECTED. ORIGINAL SQLCODE=${original-sqlcode} AND ORIG
INAL SQLSTATE=${original-sqlstateError} SQL ${codes}
-011 COMMENT NOT CLOSED
-051 ${name} (${sqltype}) WAS PREVIOUSLY DECLARED OR REFERENCED
-056 AN SQLSTATE OR SQLCODE VARIABLE DECLARATION IS IN A NESTED COMPOUND
STATEMENT
-058 VALUE SPECIFIED ON RETURN STATEMENT MUST BE AN INTEGER
-078 PARAMETER NAMES MUST BE SPECIFIED FOR ROUTINE ${routine-name}
-079 QUALIFIER FOR OBJECT ${name} WAS SPECIFIED AS ${qualifier1} ${but}
${qualifier2} IS REQUIRED
-087 A NULL VALUE WAS SPECIFIED IN A CONTEXT WHERE A NULL IS NOT ALLOWED
-096 VARIABLE ${variable-name} DOES NOT EXIST OR IS NOT SUPPORTED BY THE
SERVER AND A DEFAULT VALUE WAS NOT PROVIDED
-101 THE STATEMENT IS TOO LONG OR TOO COMPLEX
-102 STRING CONSTANT IS TOO LONG. STRING BEGINS ${string}
-103 ${constant} IS AN INVALID NUMERIC CONSTANT
-110 INVALID HEXADECIMAL CONSTANT BEGINNING ${constant}
-112 THE OPERAND OF AN AGGREGATE FUNCTION INCLUDES AN AGGREGATE FUNCTION
, AN OLAP SPECIFICATION, OR A SCALAR FULLSELECT
-113 INVALID CHARACTER FOUND IN: ${string}, REASON CODE ${nnn}
-119 A COLUMN OR EXPRESSION IN A HAVING CLAUSE IS NOT VALID
-120 AN AGGREGATE FUNCTION OR OLAP SPECIFICATION IS NOT VALID IN THE CON
TEXT IN WHICH IT WAS INVOKED
-121 THE COLUMN ${name} IS IDENTIFIED MORE THAN ONCE IN THE INSERT OR UP
DATE OPERATION OR SET TRANSITION VARIABLE STATEMENT
-122 COLUMN OR EXPRESSION IN THE SELECT LIST IS NOT VALID
-127 DISTINCT IS SPECIFIED MORE THAN ONCE IN A SUBSELECT
-134 IMPROPER USE OF A STRING, LOB, OR XML VALUE
-136 SORT CANNOT BE EXECUTED BECAUSE THE SORT KEY LENGTH TOO LONG
-138 THE SECOND OR THIRD ARGUMENT OF THE SUBSTR OR SUBSTRING FUNCTION IS
OUT OF RANGE
-147 ALTER FUNCTION ${function-name} FAILED BECAUSE SOURCE FUNCTIONS OR
NOT FENCED EXTERNAL FUNCTION CANNOT BE ALTERED
-148 THE SOURCE TABLE ${source-name} CANNOT BE ALTERED, REASON ${reason-
code}
-150 THE OBJECT OF THE INSERT, DELETE, UPDATE, MERGE, OR TRUNCATE STATEM
ENT IS A VIEW, SYSTEM-MAINTAINED MATERIALIZED QUERY TABLE, OR TRANSITI
ON TABLE FOR WHICH THE REQUESTED OPERATION IS NOT PERMITTED
-151 THE UPDATE OPERATION IS INVALID BECAUSE THE CATALOG DESCRIPTION OF
COLUMN ${column-name} INDICATES THAT IT CANNOT BE UPDATED
-159 THE STATEMENT REFERENCES ${object-name} WHICH IDENTIFIES AN ${objec
t-type} RATHER THAN AN ${expected-object-type}
-160 THE WITH CHECK OPTION CLAUSE IS NOT VALID FOR THE SPECIFIED VIEW
-187 A REFERENCE TO A CURRENT DATETIME SPECIAL REGISTER IS INVALID BECAU
SE THE MVS TOD CLOCK IS BAD OR THE MVS PARMTZ IS OUT OF RANGE
-189 CCSID ${ccsid} IS INVALID
-190 THE ATTRIBUTES SPECIFIED FOR THE COLUMN ${table-name.column-name} A
RE NOT COMPATIBLE WITH THE EXISTING COLUMN DEFINITION
-197 A QUALIFIED COLUMN NAME IS NOT ALLOWED IN THE ORDER BY CLAUSE WHEN
A SET OPERATOR IS ALSO SPECIFIED
-206 ${name} IS NOT VALID IN THE CONTEXT WHERE IT IS USED
-222 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST A HOLE USING CU
RSOR ${cursor-name}
-225 FETCH STATEMENT FOR ${cursor-name} IS NOT VALID FOR THE DECLARATION
OF THE CURSOR
-229 THE LOCALE ${locale} SPECIFIED IN A SET LC_CTYPE OR OTHER STATEMENT
THAT IS LOCALE SENSITIVE WAS NOT FOUND
-240 THE PARTITION CLAUSE OF A LOCK TABLE STATEMENT IS INVALID
-242 THE OBJECT NAMED ${object-name} OF TYPE ${object-type} WAS SPECIFIE
D MORE THAN ONCE IN THE LIST OF OBJECTS, OR THE NAME IS THE SAME AS AN
EXISTING OBJECT
-245 THE INVOCATION OF FUNCTION ${routine-name} IS AMBIGUOUS
-253 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY COMPLETED FOR SOME
OF THE REQUESTED ROWS, POSSIBLY WITH WARNINGS, AND ONE OR MORE ERRORS
-254 A NON-ATOMIC ${statement} STATEMENT ATTEMPTED TO PROCESS MULTIPLE R
OWS OF DATA, BUT ERRORS OCCURRED
-312 VARIABLE ${variable-name} IS NOT DEFINED OR NOT USABLE
-330 A STRING CANNOT BE USED BECAUSE IT CANNOT BE PROCESSED. REASON ${re
ason-code}, CHARACTER ${code-point}, HOST VARIABLE ${position-number}
-331 CHARACTER CONVERSION CANNOT BE PERFORMED BECAUSE A STRING, POSITION
${position-number}, CANNOT BE CONVERTED FROM ${source-ccsid} TO ${tar
get-ccsid}, REASON ${reason-code}
-333 THE SUBTYPE OF A STRING VARIABLE IS NOT THE SAME AS THE SUBTYPE KNO
WN AT BIND TIME AND THE DIFFERENCE CANNOT BE RESOLVED BY CHARACTER CON
VERSION
-336 THE SCALE OF THE DECIMAL NUMBER MUST BE ZERO
-342 THE COMMON TABLE EXPRESSION ${name} MUST NOT USE SELECT DISTINCT AN
D MUST USE UNION ALL BECAUSE IT IS RECURSIVE
-344 THE RECURSIVE COMMON TABLE EXPRESSION ${name} HAS MISMATCHED DATA T
YPES OR LENGTHS OR CODE PAGE FOR COLUMN ${column-name}
-345 THE FULLSELECT OF THE RECURSIVE COMMON TABLE EXPRESSION ${name} MUS
T BE A UNION ALL AND MUST NOT INCLUDE AGGREGATE FUNCTIONS, GROUP BY CL
AUSE, HAVING CLAUSE, OR AN EXPLICIT JOIN INCLUDING AN ON CLAUSE
-348 ${sequence-expression} CANNOT BE SPECIFIED IN THIS CONTEXT
-350 ${column-name} WAS IMPLICITLY OR EXPLICITLY REFERENCED IN A CONTEXT
IN WHICH IT CANNOT BE USED
-353 FETCH IS NOT ALLOWED, BECAUSE CURSOR ${cursor-name} HAS AN UNKNOWN
POSITION
-354 A ROWSET FETCH STATEMENT MAY HAVE RETURNED ONE OR MORE ROWS OF DATA
. HOWEVER, ONE OR MORE NON-TERMINATING ERROR CONDITIONS WERE ENCOUNTER
ED. USE THE GET DIAGNOSTICS STATEMENT FOR MORE INFORMATION REGARDING T
HE CONDITIONS THAT WERE ENCOUNTERED
-356 KEY EXPRESSION ${key-expr-num} IS NOT VALID, REASON CODE = ${reason
-code}
-372 ONLY ONE ROWID, IDENTITY, OR SECURITY LABEL COLUMN IS ALLOWED IN A
TABLE
-373 DEFAULT CANNOT BE SPECIFIED FOR COLUMN OR SQL VARIABLE ${name}
-374 THE CLAUSE ${clause} HAS NOT BEEN SPECIFIED IN THE CREATE OR ALTER
FUNCTION STATEMENT FOR LANGUAGE SQL FUNCTION ${function-name} BUT AN E
XAMINATION OF THE FUNCTION BODY REVEALS THAT IT SHOULD BE SPECIFIED
-390 THE FUNCTION ${function-name}, SPECIFIC NAME ${specific-name}, IS N
OT VALID IN THE CONTEXT WHERE IT IS USED
-397 GENERATED IS SPECIFIED AS PART OF A COLUMN DEFINITION, BUT IT IS NO
T VALID FOR THE DEFINITION OF THE COLUMN
-399 INVALID VALUE ROWID WAS SPECIFIED
-405 THE NUMERIC CONSTANT ${constant} CANNOT BE USED AS SPECIFIED BECAUS
E IT IS OUT OF RANGE
-408 THE VALUE IS NOT COMPATIBLE WITH THE DATA TYPE OF ITS TARGET. TARGE
T NAME IS ${name}
-410 A NUMERIC VALUE ${value} IS TOO LONG, OR IT HAS A VALUE THAT IS NOT
WITHIN THE RANGE OF ITS DATA TYPE
-415 THE CORRESPONDING COLUMNS, ${column-number}, OF THE OPERANDS OF A S
ET OPERATOR ARE NOT COMPATIBLE
-416 AN OPERAND OF A SET OPERATOR CONTAINS A LONG STRING COLUMN
-421 THE OPERANDS OF A SET OPERATOR DO NOT HAVE THE SAME NUMBER OF COLUM
NS
-431 ROUTINE ${routine-name} (SPECIFIC NAME ${specific-name}) OF TYPE ${
routine-type} HAS BEEN INTERRUPTED BY THE USER
-435 AN INVALID SQLSTATE ${sqlstate} IS SPECIFIED IN A RAISE_ERROR FUNCT
ION, RESIGNAL STATEMENT, OR SIGNAL STATEMENT
-440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND IN THE CURRENT PATH
-441 INVALID USE OF DISTINCT OR ALL WITH FUNCTION ${function-name}
-443 ROUTINE ${routine-name} (SPECIFIC NAME ${specific-name}) HAS RETURN
ED AN ERROR SQLSTATE WITH DIAGNOSTIC TEXT ${msg-text}
-451 THE ${data-item} DEFINITION IN THE CREATE OR ALTER STATEMENT FOR ${
routine-name} CONTAINS DATA TYPE ${type} WHICH IS NOT SUPPORTED FOR TH
E TYPE AND LANGUAGE OF THE ROUTINE
-452 UNABLE TO ACCESS THE FILE REFERENCED BY HOST VARIABLE ${variable-po
sition}. REASON CODE: ${reason-code}
-504 CURSOR NAME ${cursor-name} IS NOT DECLARED
-511 THE FOR UPDATE CLAUSE CANNOT BE SPECIFIED BECAUSE THE RESULT TABLE
DESIGNATED BY THE SELECT STATEMENT CANNOT BE MODIFIED
-516 THE DESCRIBE STATEMENT DOES NOT SPECIFY A PREPARED STATEMENT
-525 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS IN ERROR AT BIN
D TIME FOR SECTION = ${sectno} PACKAGE = ${pkgname} CONSISTENCY TOKEN
= ${contoken}
-526 THE REQUESTED OPERATION OR USAGE DOES NOT APPLY TO ${table-type} TE
MPORARY TABLE ${table-name}
-532 THE RELATIONSHIP ${constraint-name} RESTRICTS THE DELETION OF ROW W
ITH RID X ${rid-number}
-553 ${auth-id} SPECIFIED IS NOT ONE OF THE VALID AUTHORIZATION IDS FOR
REQUESTED OPERATION
-554 AN AUTHORIZATION ID OR ROLE CANNOT GRANT A PRIVILEGE TO ITSELF
-555 AN AUTHORIZATION ID OR ROLE CANNOT REVOKE A PRIVILEGE FROM ITSELF
-575 VIEW ${view-name} CANNOT BE REFERENCED
-583 THE USE OF FUNCTION OR EXPRESSION ${name} IS INVALID BECAUSE IT IS
NOT DETERMINISTIC OR HAS AN EXTERNAL ACTION
-584 INVALID USE OF NULL
-585 THE COLLECTION ${collection-id} APPEARS MORE THAN ONCE IN THE SET $
{special-register} STATEMENT
-586 THE TOTAL LENGTH OF THE CURRENT PATH SPECIAL REGISTER CANNOT EXCEED
2048 CHARACTERS
-590 NAME ${name} IS NOT UNIQUE IN THE CREATE OR ALTER FOR ROUTINE ${rou
tine-name}
-593 NOT NULL MUST BE SPECIFIED FOR ROWID (OR DISTINCT TYPE FOR ROWID) O
R ROW CHANGE TIMESTAMP COLUMN ${column-name}
-601 THE NAME (VERSION OR VOLUME SERIAL NUMBER) OF THE OBJECT TO BE DEFI
NED OR THE TARGET OF A RENAME STATEMENT IS IDENTICAL TO THE EXISTING N
AME (VERSION OR VOLUME SERIAL NUMBER) ${name} OF THE OBJECT TYPE ${obj
-type}
-602 TOO MANY COLUMNS OR KEY-EXPRESSIONS SPECIFIED IN A CREATE INDEX OR
ALTER INDEX STATEMENT
-612 ${identifier} IS A DUPLICATE NAME
-620 KEYWORD ${keyword} IN ${stmt-type} STATEMENT IS NOT PERMITTED FOR A
${space-type} SPACE IN THE ${database-type} DATABASE
-624 TABLE ${table-name} ALREADY HAS A PRIMARY KEY OR UNIQUE CONSTRAINT
WITH SPECIFIED COLUMNS
-627 THE ALTER STATEMENT IS INVALID BECAUSE THE TABLE SPACE OR INDEX HAS
USER-MANAGED DATA SETS
-636 RANGES SPECIFIED FOR PARTITION ${part-num} ARE NOT VALID
-637 DUPLICATE ${keyword} KEYWORD OR CLAUSE
-643 A CHECK CONSTRAINT OR THE VALUE OF AN EXPRESSION FOR A COLUMN OF AN
INDEX EXCEEDS THE MAXIMUM ALLOWABLE LENGTH KEY EXPRESSION
-644 INVALID VALUE SPECIFIED FOR KEYWORD OR CLAUSE ${keyword-or-clause}
IN STATEMENT ${stmt-type}
-647 BUFFERPOOL ${bp-name} FOR IMPLICIT OR EXPLICIT TABLESPACE OR INDEXS
PACE ${name} HAS NOT BEEN ACTIVATED
-661 ${object-type} ${index-name} CANNOT BE CREATED ON PARTITIONED TABLE
SPACE ${tspace-name} BECAUSE THE NUMBER OF PARTITION SPECIFICATIONS I
S NOT EQUAL TO THE NUMBER OF PARTITIONS OF THE TABLE SPACE
-662 A PARTITIONED INDEX CANNOT BE CREATED ON A NON-PARTITIONED, PARTITI
ON-BY-GROWTH OR RANGE-PARTITIONED UNIVERSAL TABLE SPACE ${tspace-name}
-665 THE PARTITION CLAUSE OF AN ALTER STATEMENT IS OMITTED OR INVALID
-676 THE PHYSICAL CHARACTERISTICS OF THE INDEX ARE INCOMPATIBLE WITH RES
PECT TO THE SPECIFIED STATEMENT. THE STATEMENT HAS FAILED. REASON ${re
ason-code}
-678 THE CONSTANT ${constant} SPECIFIED FOR THE INDEX LIMIT KEY MUST CON
FORM TO THE DATA TYPE ${data-type} OF THE CORRESPONDING COLUMN ${colum
n-name}
-684 THE LENGTH OF CONSTANT LIST BEGINNING ${string} IS TOO LONG
-693 THE COLUMN ${column-name} IN DDL REGISTRATION TABLE OR INDEX ${name
} IS NOT DEFINED PROPERLY
-694 THE SCHEMA STATEMENT CANNOT BE EXECUTED BECAUSE A DROP IS PENDING O
N THE DDL REGISTRATION TABLE ${table-name}
-695 INVALID VALUE ${seclabel} SPECIFIED FOR SECURITY LABEL COLUMN OF TA
BLE ${table-name}
-713 THE REPLACEMENT VALUE FOR ${special-register} IS INVALID
-748 AN INDEX ${index-name} ALREADY EXISTS ON AUXILIARY TABLE ${table-na
me}
-750 THE SOURCE TABLE ${table-name} CANNOT BE RENAMED BECAUSE IT IS REFE
RENCED IN EXISTING VIEW, MATERIALIZED QUERY TABLE, OR TRIGGER DEFINITI
ONS, IS A CLONE TABLE, OR HAS A CLONE TABLE DEFINED FOR IT
-770 TABLE ${table-name} CANNOT HAVE A LOB COLUMN UNLESS IT ALSO HAS A R
OWID, OR AN XML COLUMN UNLESS IT ALSO HAS A DOCID COLUMN
-773 CASE NOT FOUND FOR CASE STATEMENT
-776 USE OF CURSOR ${cursor-name} IS NOT VALID
-778 ENDING LABEL ${label} DOES NOT MATCH THE BEGINNING LABEL
-779 LABEL ${label} SPECIFIED ON A GOTO, ITERATE, OR LEAVE STATEMENT IS
NOT VALID
-780 UNDO SPECIFIED FOR A HANDLER
-781 CONDITION ${condition-name} IS NOT DEFINED OR THE DEFINITION IS NOT
IN SCOPE
-782 A CONDITION OR SQLSTATE ${value} SPECIFIED IS NOT VALID
-783 SELECT LIST FOR CURSOR ${cursor-name} IN FOR STATEMENT IS NOT VALID
. COLUMN ${column-name} IS NOT UNIQUE
-785 USE OF SQLCODE OR SQLSTATE IS NOT VALID
-787 RESIGNAL STATEMENT ISSUED OUTSIDE OF A HANDLER
-788 THE SAME ROW OF TARGET TABLE ${table-name} WAS IDENTIFIED MORE THAN
ONCE FOR AN UPDATE OPERATION OF THE MERGE STATEMENT
-789 THE DATA TYPE FOR THE VARIABLE ${name} IS NOT SUPPORTED IN THE SQL
ROUTINE
-797 THE TRIGGER ${trigger-name} IS DEFINED WITH AN UNSUPPORTED TRIGGERE
D SQL STATEMENT
-798 A VALUE CANNOT BE SPECIFIED FOR COLUMN ${column-name} WHICH IS DEFI
NED AS GENERATED ALWAYS
-803 AN INSERTED OR UPDATED VALUE IS INVALID BECAUSE THE INDEX IN INDEX
SPACE ${indexspace-name} CONSTRAINS COLUMNS OF THE TABLE SO NO TWO ROW
S CAN CONTAIN DUPLICATE VALUES IN THOSE COLUMNS. RID OF EXISTING ROW I
S X ${rid}
-845 A PREVIOUS VALUE EXPRESSION CANNOT BE USED BEFORE THE NEXT VALUE EX
PRESSION GENERATES A VALUE IN THE CURRENT APPLICATION PROCESS FOR SEQU
ENCE ${sequence-name}
-873 THE STATEMENT REFERENCED DATA ENCODED WITH DIFFERENT ENCODING SCHEM
ES OR CCSIDS IN AN INVALID CONTEXT
-876 ${object} CANNOT BE CREATED OR ALTERED, REASON ${reason}
-878 THE PLAN_TABLE USED FOR EXPLAIN CANNOT BE ASCII
-900 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE APPLICATION PROCES
S IS NOT CONNECTED TO A SERVER
-907 AN ATTEMPT WAS MADE TO MODIFY THE TARGET TABLE, ${table-name}, OF T
HE MERGE STATEMENT BY CONSTRAINT OR TRIGGER ${name}
-910 THE SQL STATEMENT CANNOT ACCESS AN OBJECT ON WHICH UNCOMMITTED CHAN
GES ARE PENDING
-951 OBJECT ${object-name} OBJECT TYPE ${object-type} IS IN USE AND CANN
OT BE THE TARGET OF THE SPECIFIED ALTER STATEMENT
-989 AFTER TRIGGER ${trigger-name} ATTEMPTED TO MODIFY A ROW IN TABLE ${
table-name} THAT WAS MODIFIED BY AN SQL DATA CHANGE STATEMENT WITHIN A
FROM CLAUSE
-992 PACKAGE ${package-name} CANNOT BE EXECUTED OR DEPLOYED ON LOCATION
${location-name}
-1403 THE USERNAME AND/OR PASSWORD SUPPLIED IS INCORRECT
-4302 JAVA STORED PROCEDURE OR USER-DEFINED FUNCTION ${routine-name} (SP
ECIFIC NAME ${specific-name}) HAS EXITED WITH AN EXCEPTION ${exception
-string}
-4701 THE NUMBER OF PARTITIONS, OR THE COMBINATION OF THE NUMBER OF TABL
E SPACE PARTITIONS AND THE CORRESPONDING LENGTH OF THE PARTITIONING LI
MIT KEY EXCEEDS THE SYSTEM LIMIT
-4702 THE MAXIMUM NUMBER OF ALTERS ALLOWED HAS BEEN EXCEEDED FOR ${objec
t-type}
-4703 THE ALTER TABLE STATEMENT CANNOT BE EXECUTED BECAUSE COLUMN ${colu
mn-name} IS MIXED DATA, OR THE DATA TYPE OR LENGTH SPECIFIED DOES NOT
AGREE WITH THE EXISTING DATA TYPE OR LENGTH
-4704 AN UNSUPPORTED DATA TYPE WAS ENCOUNTERED AS AN INCLUDE COLUMN
-4705 ${option} SPECIFIED ON ALTER PROCEDURE FOR PROCEDURE ${routinename
} IS NOT VALID
-4706 ALTER PROCEDURE STATEMENT CANNOT BE PROCESSED BECAUSE THE OPTIONS
IN EFFECT ARE NOT THE SAME AS THE ONES THAT WERE IN EFFECT (ENVID ${en
vid}) WHEN THE PROCEDURE OR VERSION WAS FIRST DEFINED
-4707 STATEMENT ${statement} IS NOT ALLOWED WHEN USING A TRUSTED CONNECT
ION
-4708 TABLE ${table-name} CANNOT BE DEFINED AS SPECIFIED IN THE ${statem
ent} STATEMENT IN A COMMON CRITERIA ENVIRONMENT
-4709 EXPLAIN MONITORED STMTS FAILED WITH REASON CODE = ${yyyyy}
-4710 EXCHANGE DATA STATEMENT SPECIFIED ${table1} ${and} ${table2} BUT T
HE TABLES DO NOT HAVE A DEFINED CLONE RELATIONSHIP
-5001 TABLE ${table-name} IS NOT VALID
-5012 HOST VARIABLE ${host-variable} IS NOT EXACT NUMERIC WITH SCALE ZER
O
-7008 ${object-name} NOT VALID FOR OPERATION (${reason-code}) -${skel}
-16000 AN XQUERY EXPRESSION CANNOT BE PROCESSED BECAUSE THE ${context-co
mponent} COMPONENT OF THE STATIC CONTEXT HAS NOT BEEN ASSIGNED. ERROR
QNAME = ${err}:XPST0001
-16001 AN XQUERY EXPRESSION STARTING WITH TOKEN ${token} CANNOT BE PROCE
SSED BECAUSE THE FOCUS COMPONENT OF THE DYNAMIC CONTEXT HAS NOT BEEN A
SSIGNED. ERROR QNAME = ${err}:XPDY0002
-16002 AN XQUERY EXPRESSION HAS AN UNEXPECTED TOKEN ${token} FOLLOWING $
{text}. EXPECTED TOKENS MAY INCLUDE: ${token-list}. ERROR QNAME= ERR:X
PST0003
-16003 AN EXPRESSION OF DATA TYPE ${value-type} CANNOT BE USED WHEN THE
DATA TYPE ${expected-type} IS EXPECTED IN THE CONTEXT. ERROR QNAME= ${
err}:XPTY0004
-16005 AN XQUERY EXPRESSION REFERENCES AN ELEMENT NAME, ATTRIBUTE NAME,
TYPE NAME, FUNCTION NAME, NAMESPACE PREFIX, OR VARIABLE NAME ${undefin
ed-name} THAT IS NOT DEFINED WITHIN THE STATIC CONTEXT. ERROR QNAME= E
RR:XPST0008
-16007
-16009 AN XQUERY FUNCTION NAMED ${function-name} WITH ${number-of-parms}
PARAMETERS IS NOT DEFINED IN THE STATIC CONTEXT. ERROR QNAME= ${err}:
XPST0017
-16011 THE RESULT OF AN INTERMEDIATE STEP EXPRESSION IN AN XQUERY PATH E
XPRESSION CONTAINS AN ATOMIC VALUE. ERROR QNAME = ${err}:XPTY0019
-16012 THE CONTEXT ITEM IN AN AXIS STEP MUST BE A NODE. ERROR QNAME = ${
err}:XPTY0020
-16015 AN ELEMENT CONSTRUCTOR CONTAINS AN ATTRIBUTE NODE NAMED ${attribu
te-name} THAT FOLLOWS AN XQUERY NODE THAT IS NOT AN ATTRIBUTE NODE. ER
ROR QNAME = ERR:XQTY0024
-16016 THE ATTRIBUTE NAME ${attribute-name} CANNOT BE USED MORE THAN ONC
E IN AN ELEMENT CONSTRUCTOR. ERROR QNAME = ${err}:XQTY0025
-16020 THE CONTEXT NODE IN A PATH EXPRESSION THAT BEGINS WITH AN INITIAL
?/? OR ?//? DOES NOT HAVE AN XQUERY DOCUMENT NODE ROOT. ERROR QNAME =
${err}:XPDY0050
-16022 OPERANDS OF TYPES ${xquery-data-types} ARE NOT VALID FOR OPERATOR
${operator-name} . ERROR QNAME = ${err}:XPTY0004
-16023 THE XQUERY PROLOG CANNOT CONTAIN MULTIPLE DECLARATIONS FOR THE SA
ME NAMESPACE PREFIX ${ns-prefix}. ERROR QNAME = ${err}:XQST0033
-16024 THE NAMESPACE PREFIX ${prefix-name} CANNOT BE REDECLARED OR CANNO
T BE BOUND TO THE SPECIFIED URI. ERROR QNAME = ${err}:XQST0070
-16031 XQUERY LANGUAGE FEATURE USING SYNTAX ${string} IS NOT SUPPORTED
-16032 THE STRING ${string} IS NOT A VALID URI. ERROR QNAME = ${err}:XQS
T0046
-16036 THE URI THAT IS SPECIFIED IN A NAMESPACE DECLARATION CANNOT BE A
ZERO-LENGTH STRING
-16046 A NUMERIC XQUERY EXPRESSION ATTEMPTED TO DIVIDE BY ZERO. ERROR QN
AME = ${err}:FOAR0001
-16047 AN XQUERY EXPRESSION RESULTED IN ARITHMETIC OVERFLOW OR UNDERFLOW
. ERROR QNAME= ${err}:FOAR0002
-16048 AN XQUERY PROLOG CANNOT CONTAIN MORE THAN ONE ${decl-type} DECLAR
ATION. ERROR QNAME = ${error-qname}
-16049 THE LEXICAL VALUE ${value} IS NOT VALID FOR THE ${type-name} DATA
TYPE IN THE FUNCTION OR CAST. ERROR QNAME= ${err}:FOCA0002
-16051 THE VALUE ${value} OF DATA TYPE ${source-type} IS OUT OF RANGE FO
R AN IMPLICIT OR EXPLICIT CAST TO TARGET DATA TYPE ${target-type}. ERR
OR QNAME = ${err}:${error-qname}
-16061 THE VALUE ${value} CANNOT BE CONSTRUCTED AS, OR CAST (USING AN IM
PLICIT OR EXPLICIT CAST) TO THE DATA TYPE ${data-type}. ERROR QNAME =
${err}:FORG0001
-16065 AN EMPTY SEQUENCE CANNOT BE CAST TO THE DATA TYPE ${data-type}, E
RROR QNAME = ${err}:FORG0006
-16066 THE ARGUMENT PASSED TO THE AGGREGATE FUNCTION ${function-name} IS
NOT VALID. ERROR QNAME = ${err}:FORG0006
-16075 THE SEQUENCE TO BE SERIALIZED CONTAINS AN ITEM THAT IS AN ATTRIBU
TE NODE. ERROR QNAME = ${err}:SENR0001
-16246 INCOMPLETE ANNOTATION MAPPING AT OR NEAR LINE ${lineno} IN XML SC
HEMA DOCUMENT ${uri}. REASON CODE = ${reason-code}.
-16247 SOURCE XML TYPE ${source-data-type} CANNOT BE MAPPED TO TARGET SQ
L TYPE ${target-data-type} IN THE ANNOTATION AT OR NEAR LINE ${lineno}
IN XML SCHEMA DOCUMENT ${uri}
-16248 UNKNOWN ANNOTATION ${annotation-name} AT OR NEAR LINE ${lineno} I
N XML SCHEMA DOCUMENT ${uri}
-16249 THE ${db2-xdb}:${expression} ANNOTATION ${expression} AT OR NEAR
LINE ${lineno} IN XML SCHEMA DOCUMENT ${uri} IS TOO LONG.
-16250 THE ${db2-xdb}:${defaultSQLSchema} WITH VALUE ${schema-name} AT O
R NEAR LINE ${lineno} IN XML SCHEMA DOCUMENT ${uri} CONFLICTS WITH ANO
THER ${db2-xdb}:${defaultSQLSchema} SPECIFIED IN ONE OF THE XML SCHEMA
DOCUMENTS WITHIN THE SAME XML SCHEMA.
-16251 DUPLICATE ANNOTATION DEFINED FOR ${object-name} AT OR NEAR ${loca
tion} IN XML SCHEMA DOCUMENT ${uri}
-16252 THE ${db2-xdb}:${rowSet} NAME ${rowset-name} SPECIFIED AT OR NEAR
LINE ${lineno} IN THE XML SCHEMA DOCUMENT ${uri} IS ALREADY ASSOCIATE
D WITH ANOTHER TABLE
-16253 THE ${db2-xdb}:${condition} ANNOTATION ${condition} AT OR NEAR LI
NE ${lineno} IN XML SCHEMA DOCUMENT ${uri} IS TOO LONG.
-16254 A ${db2-xdb}:${locationPath} ${locationpath} AT OR NEAR LINE ${li
neno} IN XML SCHEMA DOCUMENT ${uri} IS NOT VALID WITH REASON CODE ${re
ason-code}.
-16255 A ${db2-xdb}:${rowSet} VALUE ${rowset-name} USED AT OR NEAR LINE
${lineno} IN XML SCHEMA DOCUMENT ${uri} CONFLICTS WITH A ${db2-xdb}:${
table} ANNOTATION WITH THE SAME NAME.
-16257 XML SCHEMA FEATURE ${feature} SPECIFIED IS NOT SUPPORTED FOR DECO
MPOSITION.
-16258 THE XML SCHEMA CONTAINS A RECURSIVE ELEMENT WHICH IS AN UNSUPPORT
ED FEATURE FOR DECOMPOSITION. THE RECURSIVE ELEMENT IS IDENTIFIED AS $
{elementnamespace} : ${elementname} OF TYPE ${typenamespace} : ${typen
ame}.
-16259 INVALID MANY-TO-MANY MAPPINGS DETECTED IN XML SCHEMA DOCUMENT ${u
ri1} NEAR LINE ${lineno1} AND IN XML SCHEMA DOCUMENT ${uri2} NEAR LINE
${lineno2}.
-16260 XML SCHEMA ANNOTATIONS INCLUDE NO MAPPINGS TO ANY COLUMN OF ANY T
ABLE.
-16262 THE ANNOTATED XML SCHEMA HAS NO COLUMNS MAPPED FOR ROWSET ${rowse
tname}.
-16265 THE XML DOCUMENT CANNOT BE DECOMPOSED USING XML SCHEMA ${xsrobjec
t-name} WHICH IS NOT ENABLED OR IS INOPERATIVE FOR DECOMPOSITION.
-16266 AN SQL ERROR OCCURRED DURING DECOMPOSITION OF DOCUMENT ${docid} W
HILE ATTEMPTING TO INSERT DATA. INFORMATION RETURNED FOR THE ERROR INC
LUDES SQLCODE ${sqlcode}, SQLSTATE ${sqlstate}, AND MESSAGE TOKENS ${t
oken-list}.
-20019 THE RESULT TYPE RETURNED FROM THE FUNCTION BODY CANNOT BE ASSIGNE
D TO THE DATA TYPE DEFINED IN THE RETURNS CLAUSE
-20060 UNSUPPORTED DATA TYPE ${data-type} ENCOUNTERED IN SQL ${object-ty
pe} ${object-name}
-20072 ${bind-type} ${bind-subtype} ERROR USING ${auth-id} AUTHORITY OPE
RATION IS NOT ALLOWED ON A ${package-type} PACKAGE ${package-name}
-20092 A TABLE OR VIEW WAS SPECIFIED IN THE LIKE CLAUSE, BUT THE OBJECT
CANNOT BE USED IN THIS CONTEXT
-20106 THE CCSID FOR THE TABLE SPACE OR DATABASE CANNOT BE CHANGED BECAU
SE THE TABLE SPACE OR DATABASE ALREADY CONTAINS A TABLE THAT IS REFERE
NCED IN EXISTING VIEW, OR MATERIALIZED QUERY TABLE DEFINITIONS OR AN E
XTENDED INDEX
-20143 THE ENCRYPTION OR DECRYPTION FUNCTION FAILED, BECAUSE THE ENCRYPT
ION PASSWORD VALUE IS NOT SET
-20144 THE ENCRYPTION IS INVALID BECAUSE THE LENGTH OF THE PASSWORD WAS
LESS THAN 6 BYTES OR GREATER THAN 127 BYTES
-20146 THE DECRYPTION FAILED. THE DATA IS NOT ENCRYPTED
-20147 THE ENCRYPTION FUNCTION FAILED. MULTIPLE PASS ENCRYPTION IS NOT S
UPPORTED
-20165 AN SQL DATA CHANGE STATEMENT WITHIN A FROM CLAUSE IS NOT ALLOWED
IN THE CONTEXT IN WHICH IT WAS SPECIFIED
-20166 AN SQL DATA CHANGE STATEMENT WITHIN A SELECT SPECIFIED A VIEW ${v
iew-name} WHICH IS NOT A SYMMETRIC VIEW OR COULD NOT HAVE BEEN DEFINED
AS A SYMMETRIC VIEW
-20178 VIEW ${view-name} ALREADY HAS AN INSTEAD OF ${operation} TRIGGER
DEFINED
-20179 THE INSTEAD OF TRIGGER CANNOT BE CREATED BECAUSE THE VIEW ${view-
name} IS DEFINED USING THE WITH CHECK OPTION
-20182 PARTITIONING CLAUSE ${clause} ON ${stmt-type} STATEMENT FOR ${ind
ex-name} IS NOT VALID
-20183 THE PARTITIONED, ADD PARTITION, ADD PARTITIONING KEY, ALTER PARTI
TION, ROTATE PARTITION, OR PARTITION BY RANGE CLAUSE SPECIFIED ON CREA
TE OR ALTER FOR ${name} IS NOT VALID
-20186 A CLAUSE SPECIFIED FOR THE DYNAMIC SQL STATEMENT BEING PROCESSED
IS NOT VALID
-20200 THE INSTALL OR REPLACE OF ${jar-id} WITH URL ${url} FAILED DUE TO
REASON ${reason-code-}(${reason-string}).
-20201 THE INSTALL, REPLACE, REMOVE, OR ALTER OF ${jar-name} FAILED DUE
TO REASON ${reason-code-}(${reason-string})
-20202 THE REMOVE OF ${jar-name} FAILED AS ${class} IS IN USE
-20210 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS PRECOMPILED A
T A LEVEL THAT IS INCOMPATIBLE WITH THE CURRENT VALUE OF THE ENCODING
BIND OPTION OR SPECIAL REGISTER
-20211 THE SPECIFICATION ORDER BY OR FETCH FIRST N ROWS ONLY IS INVALID
-20212 USER-DEFINED ROUTINE ${name} ENCOUNTERED AN EXCEPTION ATTEMPTING
TO LOAD JAVA CLASS ${class-name} FROM JAR ${jar-name}. ORIGINAL EXCEPT
ION: ${exception-string}
-20213 STORED PROCEDURE ${procedure-name} HAS RETURNED A DYNAMIC RESULT
SET, PARAMETER ${number}, THAT IS NOT VALID
-20223 THE ENCRYPT_TDES OR DECRYPT FUNCTION FAILED. ENCRYPTION FACILITY
NOT AVAILABLE ${return-code}, ${reason-code}
-20224 ENCRYPTED DATA THAT WAS ORIGINALLY A BINARY STRING CANNOT BE DECR
YPTED TO A CHARACTER STRING
-20232 CHARACTER CONVERSION FROM CCSID ${from-ccsid} TO ${to-ccsid} FAIL
ED WITH ERROR CODE ${error-code} FOR TABLE ${dbid.obid} COLUMN ${colum
n-number} REQUESTED BY ${csect-name}
-20235 THE COLUMN ${column-name} CANNOT BE ADDED OR ALTERED BECAUSE ${ta
ble-name} IS A MATERIALIZED QUERY TABLE
-20240 INVALID SPECIFICATION OF A SECURITY LABEL COLUMN ${column-name} R
EASON CODE ${reason-code}
-20243 THE VIEW ${view-name} IS THE TARGET IN THE MERGE STATEMENT, BUT I
S MISSING THE INSTEAD OF TRIGGER FOR THE ${operation} OPERATION.
-20248 ATTEMPTED TO EXPLAIN ALL CACHED STATEMENTS OR A CACHED STATEMENT
WITH STMTID OR STMTTOKEN ID-${token} BUT THE REQUIRED EXPLAIN INFORMAT
ION IS NOT ACCESSIBLE.
-20249 THE PACKAGE ${package-name} NEEDS TO BE REBOUND IN ORDER TO BE SU
CCESSFULLY EXECUTED (${token})
-20252 DIAGNOSTICS AREA FULL. NO MORE ERRORS CAN BE RECORDED FOR THE NOT
ATOMIC STATEMENT
-20257 FINAL TABLE IS NOT VALID WHEN THE TARGET VIEW ${view-name} OF THE
SQL DATA CHANGE STATEMENT IN A FULLSELECT HAS AN INSTEAD OF TRIGGER D
EFINED
-20258 INVALID USE OF INPUT SEQUENCE ORDERING
-20260 THE ASSIGNMENT CLAUSE OF THE UPDATE OPERATION AND THE VALUES CLAU
SE OF THE INSERT OPERATION MUST SPECIFY AT LEAST ONE COLUMN THAT IS NO
T AN INCLUDE COLUMN
-20264 FOR TABLE ${table-name}, ${primary-auth-id} WITH SECURITY LABEL $
{primary-auth-id-seclabel} IS NOT AUTHORIZED TO PERFORM ${operation} O
N A ROW WITH SECURITY LABEL ${row-seclabel}. THE RECORD IDENTIFIER (RI
D) OF THIS ROW IS ${rid-number}.
-20265 SECURITY LABEL IS ${reason} FOR ${primary-auth-id}
-20266 ALTER VIEW FOR ${view-name} FAILED
-20275 The XML NAME ${name} IS NOT VALID. REASON CODE = ${reason-code}
-20281 ${primary-auth-id} DOES NOT HAVE THE MLS WRITE-DOWN PRIVILEGE
-20283 A DYNAMIC CREATE STATEMENT CANNOT BE PROCESSED WHEN THE VALUE OF
CURRENT SCHEMA DIFFERS FROM CURRENT SQLID
-20286 DB2 CONVERTED STRING ${token-type} ${token} FROM ${from-ccsid} TO
${to-ccsid}, AND RESULTED IN SUBSTITUTION CHARACTERS
-20289 INVALID STRING UNIT ${unit} SPECIFIED FOR FUNCTION ${function-nam
e}
-20295 THE EXECUTION OF A BUILT IN FUNCTION ${function} RESULTED IN AN E
RROR REASON CODE ${reason-code}
-20304 INVALID INDEX DEFINITION INVOLVING AN XMLPATTERN CLAUSE OR A COLU
MN OF DATA TYPE XML. REASON CODE = ${reason-code}
-20305 AN XML VALUE CANNOT BE INSERTED OR UPDATED BECAUSE OF AN ERROR DE
TECTED WHEN INSERTING OR UPDATING THE INDEX IDENTIFIED BY ${index-id}
ON TABLE ${table-name}. REASON CODE = ${reason-code}
-20306 AN INDEX ON AN XML COLUMN CANNOT BE CREATED BECAUSE OF AN ERROR D
ETECTED WHEN INSERTING THE XML VALUES INTO THE INDEX. REASON CODE = ${
reason-code}
-20310 THE REMOVE OF ${jar-name1} FAILED, AS IT IS IN USE BY ${jar-name2
}
-20311 THE VALUE PROVIDED FOR THE NEW JAVA PATH IS ILLEGAL
-20312 THE ALTER OF JAR ${jar-id} FAILED BECAUSE THE SPECIFIED PATH REFE
RENCES ITSELF
-20313 DEBUG MODE OPTION FOR ROUTINE ${routine-name} CANNOT BE CHANGED
-20314 THE PARAMETER LIST DOES NOT MATCH THE PARAMETER LIST FOR ALL OTHE
R VERSIONS OF ROUTINE ${routine-name}
-20315 THE CURRENTLY ACTIVE VERSION FOR ROUTINE ${routine-name} (${type}
) CANNOT BE DROPPED
-20326 AN XML ELEMENT NAME, ATTRIBUTE NAME, NAMESPACE PREFIX OR URI ENDI
NG WITH ${string} EXCEEDS THE LIMIT OF 1000 BYTES
-20327 THE DEPTH OF AN XML DOCUMENT EXCEEDS THE LIMIT OF 128 LEVELS
-20328 THE DOCUMENT WITH TARGET NAMESPACE ${namespace} AND SCHEMA LOCATI
ON ${location} HAS ALREADY BEEN ADDED FOR THE XML SCHEMA IDENTIFIED BY
${schema} ${name}
-20329 THE COMPLETION CHECK FOR THE XML SCHEMA FAILED BECAUSE ONE OR MOR
E XML SCHEMA DOCUMENTS IS MISSING. ONE MISSING XML SCHEMA DOCUMENT IS
IDENTIFIED BY ${uri-type} AS ${uri}
-20330 THE ${xsrobject-type} IDENTIFIED BY XML ${uri-type1} ${uri1} AND
XML ${uri-type2} ${uri2} IS NOT FOUND IN THE XML SCHEMA REPOSITORY
-20331 THE XML COMMENT VALUE ${string} IS NOT VALID
-20332 THE XML PROCESSING INSTRUCTION VALUE ${string} IS NOT VALID
-20335 MORE THAN ONE ${xsrobject-type} EXISTS IDENTIFIED BY XML ${uri-ty
pe1} ${uri1} AND ${uri-type2} ${uri2} EXISTS IN THE XML SCHEMA REPOSIT
ORY.
-20339 XML SCHEMA ${name} IS NOT IN THE CORRECT STATE TO PERFORM OPERATI
ON ${operation}
-20340 XML SCHEMA ${xmlschema-name} INCLUDES AT LEAST ONE XML SCHEMA DOC
UMENT IN NAMESPACE ${namespace} THAT IS NOT CONNECTED TO THE OTHER XML
SCHEMA DOCUMENTS
-20345 THE XML VALUE IS NOT A WELL-FORMED DOCUMENT WITH A SINGLE ROOT EL
EMENT
-20353 AN OPERATION INVOLVING COMPARISON CANNOT USE OPERAND ${name} DEFI
NED AS DATA TYPE ${type-name}
-20354 INVALID SPECIFICATION OF A ROW CHANGE TIMESTAMP COLUMN FOR TABLE
${table-name}
-20355 THE STATEMENT COULD NOT BE PROCESSED BECAUSE ONE OR MORE IMPLICIT
LY CREATED OBJECTS ARE INVOLVED ${reason-code}
-20356 THE TABLE WITH DBID = ${dbid} AND OBID = ${obid} CANNOT BE TRUNCA
TED BECAUSE DELETE TRIGGERS EXIST FOR THE TABLE, OR THE TABLE IS THE P
ARENT TABLE IN A REFERENTIAL CONSTRAINT
-20361 AUTHORIZATION ID ${authorization-name} IS NOT DEFINED FOR THE TRU
STED CONTEXT ${context-name}
-20362 ATTRIBUTE ${attribute-name} WITH VALUE ${value} CANNOT BE DROPPED
BECAUSE IT IS NOT PART OF THE DEFINITION OF TRUSTED CONTEXT ${context
-name}
-20363 ATTRIBUTE ${attribute-name} WITH VALUE ${value} IS NOT A UNIQUE S
PECIFICATION FOR TRUSTED CONTEXT ${context-name}
-20365 A SIGNALING NAN WAS ENCOUNTERED, OR AN EXCEPTION OCCURRED IN AN A
RITHMETIC OPERATION OR FUNCTION INVOLVING A DECFLOAT
-20366 TABLE WITH DBID=${dbid.obid} AND OBID= ${obid} CANNOT BE TRUNCATE
D BECAUSE UNCOMMITTED UPDATES EXIST ON THE TABLE WITH 'IMMEDIATE' OPTI
ON SPECIFIED IN THE STATEMENT
-20369 AN ALTER TRUSTED CONTEXT STATEMENT FOR ${context-name} ATTEMPTED
TO REMOVE THE LAST CONNECTION TRUST ATTRIBUTE ASSOCIATED WITH THE TRUS
TED CONTEXT
-20372 THE SYSTEM AUTHID CLAUSE OF A CREATE OR ALTER TRUSTED CONTEXT STA
TEMENT FOR ${context-name} SPECIFIED ${authorization-name}, BUT ANOTHE
R TRUSTED CONTEXT IS ALREADY DEFINED FOR THAT AUTHORIZATION ID.
-20373 A CREATE OR ALTER TRUSTED CONTEXT STATEMENT SPECIFIED ${authoriza
tion-name} MORE THAN ONCE OR THE TRUSTED CONTEXT IS ALREADY DEFINED TO
BE USED BY THIS AUTHORIZATION ID OR PUBLIC.
-20374 AN ALTER TRUSTED CONTEXT STATEMENT FOR ${context-name} SPECIFIED
${authorization-name} BUT THE TRUSTED CONTEXT IS NOT CURRENTLY DEFINED
TO BE USED BY THIS AUTHORIZATION ID OR PUBLIC
-20377 AN ILLEGAL XML CHARACTER ${hex-char} WAS FOUND IN AN SQL/XML EXPR
ESSION OR FUNCTION ARGUMENT THAT BEGINS WITH STRING ${start-string}
-20380 ALTER INDEX WITH REGENERATE OPTION FOR ${index-name} FAILED. INFO
RMATION RETURNED: SQLCODE ${sqlcode}, SQLSTATE ${sqlstate}, MESSAGE TO
KENS ${token-list}
-20381 ALTER INDEX WITH REGENERATE OPTION IS NOT VALID FOR ${index-name}
-20382 CONTEXT ITEM CANNOT BE A SEQUENCE WITH MORE THAN ONE ITEM
-20398 ERROR ENCOUNTERED DURING XML PARSING AT LOCATION ${n} ${text}
-20399 XML PARSING OR VALIDATION ERROR ENCOUNTERED DURING XML SCHEMA VAL
IDATION AT LOCATION ${n} ${text}
-20400 XML SCHEMA ERROR ${n} ${text}
-20409 AN XML DOCUMENT OR CONSTRUCTED XML VALUE CONTAINS A COMBINATION O
F XML NODES THAT CAUSES AN INTERNAL IDENTIFIER LIMIT TO BE EXCEEDED
-20410 THE NUMBER OF CHILDREN NODES OF AN XML NODE IN AN XML VALUE HAS E
XCEEDED THE LIMIT NUMBER OF CHILDREN NODES
-20411 A FETCH CURRENT CONTINUE OPERATION WAS REQUESTED FOR ${cursor-nam
e} BUT THERE IS NO PRESERVED, TRUNCATED DATA TO RETURN
-20412 SERIALIZATION OF AN XML VALUE RESULTED IN CHARACTERS THAT COULD N
OT BE REPRESENTED IN THE TARGET ENCODING
-20422 A CREATE TABLE, OR DECLARE GLOBAL TEMPORARY TABLE STATEMENT FOR $
{table-name} ATTEMPTED TO CREATE A TABLE WITH ALL THE COLUMNS DEFINED
AS HIDDEN
-20433 AN UNTYPED PARAMETER MARKER WAS SPECIFIED, BUT AN ASSUMED DATA TY
PE CANNOT BE DETERMINED FROM ITS USE
-30005 EXECUTION FAILED BECAUSE FUNCTION NOT SUPPORTED BY THE SERVER: LO
CATION ${location} PRODUCT ID ${pppvvrr} REASON ${reason-code} (${sub-
code})
-30020 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT CAUSED
DEALLOCATION OF THE CONVERSATION: REASON ${reason-code} (${sub-code})
-30025 EXECUTION FAILED BECAUSE FUNCTION IS NOT SUPPORTED BY THE SERVER
WHICH CAUSED TERMINATION OF THE CONNECTION: LOCATION ${location} PRODU
CT ID ${pppvvrr} REASON ${reason-code} (${sub-code})
-30041 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL AFFECT TH
E SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS AND SQL STATEMENTS. REAS
ON ${reason-code} TYPE OF RESOURCE ${resource-type} RESOURCE NAME ${re
source-name} PRODUCT ID ${pppvvrrm} RDBNAME ${rdbname}
-30050 ${command-or-SQL-statement-type} COMMAND OR SQL STATEMENT INVALID
WHILE BIND PROCESS IN PROGRESS
-30081 ${prot} COMMUNICATIONS ERROR DETECTED. API=${api}, LOCATION=${loc
}, FUNCTION=${func}, ERROR CODES=${rc1} ${rc2} ${rc3}
>>>>> sqlCodes V9 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
}¢--- A540769.WK.REXX(SQLDIV) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 ---
/* 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
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 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 *************************************************/
}¢--- A540769.WK.REXX(SQLS) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 -----
/* 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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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 *************************************************/
}¢--- A540769.WK.REXX(TIME) cre=2016-10-26 mod=2016-10-26-09.51.11 A540769 -----
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
}¢--- A540769.WK.REXX(TMPLGEN) cre=2016-11-14 mod=2016-11-14-09.47.17 A540769 ---
$#@
$*( generate and distribute standard templates
How-To :
-----------------------------------------------------------------
MEMBER : was?
-----------------------------------------------------------------
1.GEN : wsh zum generieren der LISTDEF member
(outLib variable prüfen, kann test or produktive sein
-----------------------------------------------------------------
2.##DIST: wsh zum verteilen in alle RZs
Tipp :
mit dem block-command "qq" kann man z.b. nur ein
einzelnes RZ verteilen. wsh führt nur den code von "qq"
bis "qq" aus.
-----------------------------------------------------------------
What is generated?
-----------------------------------------------------------------
TEMPL (altes) Standard Template
copy mit 2 Varianten für mgmtClas
(1) 1 Woche auf Disk ==> für copyArchivierungs Ablauf
(2) adb#sub1: sofort archiviert (ohne copyArchivierung)
TEMPL#LO gelöscht
TEMPL#S neues System Template mit &SSID..S&PB...
TEMPL#U neues User Template mit &SSID..U&PB...
XBTEMPL Elar Template
XBTEMPL1 Elar Template
XBTEMPLN Elar Template
DXTEMPL Elar für DXB* DBs mit &SSID..U&PB..&DB(2)
history --------------------------------
v16 31. 8.16 Anpassung DISP für RECU für Q und PTA (neue VAR $dispRecU)
v15 21. 6.16 dataclass pro rz fuer recU
v14 18. 2.15 member mit plexBuchstaben statt rzNr
v13 18. 2.15 code von templ#lo eliminiert
v12 12.12.14 rz1 + templ#lo deaktiviert
v12 25. 8.14 reformat templ#lo durch templ überschrieben
v11 20. 8.14 reformat
v10 22. 7.14 erste Version mit gen
$*)
$=outLib = dsn.source.tmpl
$=outLib = A540769.tst.tmpl
$** $proc gTrg $@¢ $=trg = $rz/$dbSys.DBAA.LISTDEF $!
$proc gTrg $@¢ $=trg = $rz/A540769.TSTTMPL.$dbSys $!
$=csDist =- jOpen(file($outLib"(##dist) ::f"), '>')
call jWrite $csDist, $'$#@'
call jWrite $csDist, $'$** wsh script zum Verteilen von templates'
$= storAll = $'STORCLAS (ALL$N)'
$= storFar = $'STORCLAS(FAR$N)'
call iiIni
if 0 then $@¢ $** collect all temp from all rz -----------------------
$do ix=1 while iiIxPut(ix) $@¢
lib = $rz'/'$dbSys'.DBAA.LISTDEF'
mbId = 'T#'$rzC$dbSysC'#'
say $rz $dbSys mbrList(qq, lib'(*TEMPL*)') '==>' mbId
do qx=1 to m.qq.0
say ' ' qx m.qq.qx
call dsnCopy lib'('m.qq.qx')',
, 'A234579.tst.listOrig('repAll(m.qq.qx, 'TEMPL', mbId)')'
end
$!
exit
$! else if 0 then $@¢ $** del all old members ------------------------
$do ix=1 while iiIxPut(ix) $@¢
$@gTrg
parse value $trg with rz '/' dsn
call jWrite $csDist, "say '"$rz $dbSys"'"
call jWrite $csDist, "call dsnDel" rz", '"dsn"(TEMPL#DC)'"
call jWrite $csDist, "call dsnDel" rz", '"dsn"(TEMPL#LO)'"
call jWrite $csDist, "call dsnDel" rz", '"dsn"(TEMPL#NI)'"
$!
$! else $@¢ $** generate all templates ------------------------------
$do ix=1 while iiIxPut(ix) $@¢
$= mbId = T#$rzP$dbSysC#
call jWrite $csDist, "say '"$rz $dbSys $mbId"'"
$= pbDB = &DB.
$= uxDB = &DB.
$= lql = 3
if wordPos($dbSys, 'DBOF DBTF DE0G DPXG DPYG DPZG') > 0 then $@¢
$= copyMgmt = COM#A041
$! else $@¢
$= copyMgmt = SUB#ADB1
$!
if wordPos($rz , 'RZ2 RZ4 RQ2') > 0 then $@¢
$= dtclsRecu = ENN59
$! else $@¢
$= dtclsRecu = ENN35
$!
if wordPos($rz , 'RR2 RQ2') > 0 then $@¢
$= dispRecU = DISP(NEW,DELETE,CATLG)
$! else $@¢
$= dispRecU = DISP(NEW,DELETE,DELETE)
$!
$@%¢oneTempl - '?', 'standard system template' $!
$@%¢oneTempl - '?#S', 'standard system template' $!
if $dbSysElar then $@¢
if $dbSys == 'DVBP' then $@¢
$= xbUM = SUB#ELA2
$= xbUQ = $''
$= xbCS = (5000,5000) CYL
$= xbTS = (5000,5000) CYL
$= xbUS = (1000,100) CYL
$= xbPu = P0.&DB..&SN..SYSPUNCH.&UNIQ.
$= xbRe = P0.&DB..&SN..SYSREC.&UNIQ.
$! else $@¢
$= xbUM = COM#A019
$= xbUQ = .&UNIQ.
$= xbCS = (1500,10000) TRK
$= xbTS = (2000,600) CYL
$= xbUS = (2000,600) CYL
$= xbPu = S0.&DB..&SN..D&YE(3).&MO.&DA..T&MI.&SC.
$= xbRe = S0.&DB..&SN..APROC(+1)
$!
$@%¢oneTempl - 'XB?', 'xb template' $!
if $dbSys <> 'DVBP' then $@¢
$= pbDB = U&PB..&DB.
$= uxDB = UX.&DB.
$= lql = 2
$!
$@%¢oneTempl - 'XB?N', 'xb template' $!
$@%¢oneTempl - 'XB?1', 'xb template' $!
$= pbDB = U&PB..&DB(2).
$= uxDB = UX.&DB(2).
$= lql = 2
$@%¢oneTempl - 'DX?', 'dxb (temporary) template' $!
$!
$= pbDB = U&PB..&DB.
$= uxDB = UX.&DB.
$= lql = 2
$@%¢oneTempl - '?#U', 'standard user template' $!
$!
$!
call jClose $csDist
call adrIsp "view dataset('"$outLib"(##dist)')", 4
$** -------------------------------------------------------------------
$proc $@/oneTempl/
$@ parse arg , mMsk, txt
$= mbSrc =- repAll(mMsk, '?', $mbId)
$= mbr =- repAll(mMsk, '?', templ)
$= txt =- txt
$= reo =- left('REO', $lql)
$= srt =- if($lql = 3, 'SRT', 'SO')
$= err =- left('ERR', $lql)
$= map =- left('MAP', $lql)
$= dis =- left('DIS', $lql)
$= pun =- left('PUN', $lql)
$@gTrg
call jWrite $csDist, "call dsnCopy '"$outLib"("$mbSrc")' ,"
call jWrite $csDist, " , '"$trg"("$mbr")'"
if mMsk == 'XB?' then $@¢
$@templXB $> $outLib($mbSrc)
$! else if mMsk == 'XB?N' then $@¢
$@templXBN $> $outLib($mbSrc)
$! else if mMsk == 'XB?1' then $@¢
$@templXB1 $> $outLib($mbSrc)
$! else $@¢
$@templAll $> $outLib($mbSrc)
$!
$/oneTempl/
$proc $@=/templHead/
-- $-¢overlay($txt $mbr, right($rz $dbSys 'v=14', 69))$!
-- $-¢right('generiert am' f('%t s') $*+
'durch rz4/dsn.source.tmpl(gen)', 69)$!
$/templHead/
$proc $@/templAll/
$@templHead
$@%¢templA2 - 1 $!
$/templAll/
$proc $@=/templA2/
$@ parse arg , genPun
TEMPLATE TCOPYD -- COPYDDN fuer copy etc. (1 Tag/Woche auf Disk)
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
DATACLAS(ENN35) MGMTCLAS($copyMgmt) $storFar
SPACE (1500,10000) TRK
TEMPLATE TCOPYS -- COPYDDN anlog TCOPYD, aber mit space
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
DATACLAS(ENN35) MGMTCLAS($copyMgmt) $storFar
SPACE (800,500) CYL
TEMPLATE TCOPYD8 -- COPYDDN 1 Woche auf Disk, mit space
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
DATACLAS(ENN35) MGMTCLAS(COM#A041) $storFar
SPACE (1500,10000) TRK
TEMPLATE TCOPYT -- COPYDDN auf Tape
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
UNIT 3490 RETPD 23 STACK YES
TEMPLATE TSRECD -- UNLDDN fuer Unload
DSN('&SSID..$uxDB.&SN..P&PART..D&YE(3).&MO.&DA..REC')
DATACLAS(ENN35) MGMTCLAS(COM#A032)
SPACE TRK MAXPRIME 600
TEMPLATE TSRECO -- UNLDDN fuer offline Reorg, Delete nach 5 Tagen
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$reo')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE TRK MAXPRIME 600
TEMPLATE TSRECU -- UNLDDN fuer UTS Migration, mit sofort Delete
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..UTS')
$dispRecU
DATACLAS($dtclsRecu) MGMTCLAS(COM#E001)
SPACE CYL
TEMPLATE TSYUTD -- WORKDDN(1,) = SYSUT1 fuer check, load, merge
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..UT')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE TRK MAXPRIME 600
TEMPLATE TSYUTS -- WORKDDN(1,) = SYSUT1 wie tSyUtD mit Space
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..UT')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE (100,10000) TRK
TEMPLATE TSOUTD -- WORKDDN(,2) = SORTOUT fuer checkData, load
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$srt')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE TRK MAXPRIME 600
TEMPLATE TSOUTS -- WORKDDN(,2) = SORTOUT wie tSOutD mit space
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$srt')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE (100,10000) TRK
TEMPLATE TERRD -- ERRDDN fuer Load, CheckData
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$err')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE (100,10000) TRK
TEMPLATE TMAPD -- MAPDDN fuer load mit enforce constraints
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$map')
DATACLAS(ENN35) MGMTCLAS(COM#E005)
SPACE (100,10000) TRK
TEMPLATE TDISC -- DISCARDDN fuer Load, Reorg
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$dis')
DATACLAS(ENN35) MGMTCLAS(COM#A032)
SPACE (100,10000) TRK
$@ if genPun then $@=¢
TEMPLATE TPUNCH -- PUNCHDDN fuer reorg unload
DSN('&SSID..$uxDB.&SN..P&PART..D&YE(3).&MO.&DA..PUN')
DATACLAS(NULL8) MGMTCLAS(COM#A032)
SPACE(1,10) TRK
$!
TEMPLATE TPUNO -- PUNCHDDN fuer offline Reorg, mit sofort Delete
DSN('&SSID..$uxDB.&SN..P&PART..&UNIQ..$pun')
DATACLAS(NULL8) MGMTCLAS(COM#A032)
SPACE(1,10) TRK
$/templA2/
$proc $@=/templXB/
$@templHead
TEMPLATE TCOPYD -- COPYDDN fuer copy etc.
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
DATACLAS(ENN35) MGMTCLAS(COM#A011) $storFar
SPACE $xbCS
TEMPLATE TCOPYT -- COPYDDN auf Tape
DSN '&SSID..$pbDB.&SN..P&PART..&UNIQ.'
UNIT 3490 RETPD 9999 STACK YES
TEMPLATE TPUNCH
DSN('XB.&DB..&SN..P&PART..SYSPCH$xbUQ')
DATACLAS(NULL8) MGMTCLAS(COM#A019)
SPACE (1,1) TRK
TEMPLATE TPUNCHT
DSN 'XB.&DB..&SN..P&PART..SYSPCH$xbUQ'
UNIT 3490 RETPD 9999 STACK YES
TEMPLATE TUNL
DSN('XB.&DB..&SN..P&PART..SYSREC.&UNIQ.')
$storAll MGMTCLAS (COM#A019) DATACLAS (ENN35)
SPACE $xbTS
TEMPLATE TUNLT
DSN 'XB.&DB..&SN..P&PART..SYSREC.&UNIQ.'
UNIT 3490 RETPD 9999 STACK YES
$/templXB/
$proc $@=/templXBN/
$@templHead
TEMPLATE TCOPYD
DSN('&SSID..$pbDB.&SN..P&PART..&UNIQ.')
DATACLAS(ENN35) MGMTCLAS(COM#A011) $storFar
SPACE (1500,10000) TRK
TEMPLATE TPUNCH
DSN('XB.&DB..&SN..P&PART..SYSPCH')
$storFar MGMTCLAS ($xbUM) DATACLAS (NULL8)
SPACE (1,1) TRK
TEMPLATE TUNL
DSN('XB.&DB..&SN..P&PART..SYSREC.&UNIQ.')
$storFar MGMTCLAS ($xbUM) DATACLAS (ENN35)
SPACE (100,12000) TRK
$/templXBN/
$proc $@=/templXB1/
$@templHead
TEMPLATE TPUNCHT
UNIT 3490
DSN 'XB.DIV.$xbPu'
RETPD 9999
STACK YES
TEMPLATE TUNLT
UNIT 3490
DSN 'XB.DIV.$xbRe'
RETPD 9999
STACK YES
TEMPLATE TPUNCH
DSN 'XB.DIV.$xbPu'
DATACLAS(NULL8) MGMTCLAS(COM#A019)
SPACE (1,1) TRK
TEMPLATE TUNL
DSN 'XB.DIV.$xbRe'
DATACLAS(ENN35) MGMTCLAS(COM#A019)
SPACE $xbUS
$/templXB1/
$#out 20161114 09:42:32
$#out 20161114 09:38:56
$#out 20160831 15:23:47
$#out 20160831 15:23:26
$#out 20160728 15:14:18
$#out 20160728 15:13:21
$#out 20160621 15:46:30
$#out 20160621 15:44:51
$#out 20160621 15:44:11
*** run error ***
adr ispExec rc 20 in view dataset('~.tst.tmpl(##dist)'): '~.TST.TMPL' was not...
$#out 20160520 11:16:54
$#out 20160520 11:13:24
$#out 20160520 08:28:44
$#out 20160520 07:35:25
$#out 20160520 07:18:15
$#out 20160520 07:02:19
*** run error ***
undefined var uts
$#out 20160520 07:01:14
*** run error ***
undefined var uts
$#out 20160519 09:56:57
*** run error ***
undefined var uts
$#out 20160519 09:55:51
*** run error ***
undefined var uts
$#out 20160519 09:42:37
*** run error ***
adrTso rc= 12 stmt=alloc dd(CAT1) new catalog dataset('A234579.TST.TMPL') recfm(
IKJ56893I DATA SET A234579.TST.TMPL NOT ALLOCATED+
IGD308I DATA SET ALLOCATION REQUEST FAILED -
RACF FUNCTION: RACDEF FOR
DATA SET: A234579.TST.TMPL WITH RETURN CODE 08 REASON CODE 00
$#out 20150219 08:06:00
$#out 20150218 20:45:31
}¢--- A540769.WK.REXX(TSTALL) cre=2016-11-06 mod=2016-11-06-17.04.18 A540769 ---
/* copy tstAll begin ************************************************/
tstAll: procedure expose m.
say 'tstAll' m.myWsh m.myVers
call tstBase
call tstComp
call tstDiv
if m.err_os = 'TSO' then do
call tstZos
call tstTut0
end
call tstTimeTot
return 0
endProcedure tstAll
/*--- with also the slow tests --------------------------------------*/
tstAlLong: procedure expose m.
call tstIni
m.tst_long = 1
return tstAll()
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 ##########################################
#noPds: -99 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 = 00000D693A400000 = 14745600000000 = 3600.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-11.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
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 , 'e'
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 , 'e'
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 , 'e'
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 tst t, "tstSqlCsm"
call sqlConnect m.tst_csmRzDb, 'c'
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 sqlConnect , 'r'
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 , 'e'
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 tst t, 'tstSqlFTab'
call sqlConnect , 'r'
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 tst t, 'tstSqlFTab2'
call sqlConnect , 'r'
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 sqlConnect , 'r'
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 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 , 'e'
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.
/*
$=/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/
### 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
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.S+
YSDUMMY1 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 RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
$=/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/
*/
call pipeIni
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 , 'r'
sys = 'local'
end
else if tx=2 then do
call tst t, "tstSqlCCsm"
sys = m.tst_csmRzDb 'csm'
call sqlConnect m.tst_csmRzDb, 'c'
end
else do
call tst t, "tstSqlCWsh"
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 , 'e'
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 , 'e'
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 , 'e'
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 , 'e'
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 sqlConnect , 's'
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 pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect , 's'
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 sqlConnect , 'r'
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 sqlConnect , 'r'
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 tst t, "tstSqlS1"
call sqlConnect , 'r'
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 sqlconClass_w
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 sqlconClass_w
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 sqlConnect , 's'
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 sqlConnect , 's'
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 tstMain
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 tstCompWithNew
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 = wshHookComp(tstWWWW, spec, src)
noSyn = m.err.count = oldErr
coErr = m.t.err
if noSyn then
say "compiled" r ":" objMet(r, 'oRun')
else
say "*** syntaxed"
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;
tstR: @ obj null
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
tstCompProc: procedure expose m.
/*
$=/tstCompProc1/
### start tst tstCompProc1 ########################################
compile =, 11 lines: $$ vor1
run without input
vor1
called p1 eins
vor2
tstR: @ obj null
vor3
. called p3 drei
vor4
. called p2 .
vor9 endof
$/tstCompProc1/ */
call pipeIni
call compIni
call tstComp1 '= tstCompProc1',
, "$$ vor1",
, "$@% p1 eins $$vor2 $@% p2 zwei $$vor3 $@% p3 drei",
, "$$ vor4 $proc p1 $$- 'called p1' arg(2)",
, "$proc p2", " ", "$** a", "$*(b$*) called p2 $-¢arg(2)$!",
, "$proc p3 ", "$** a", " $*(b$*) called p3 $-¢arg(2)$!",
, "$$ vor9 endof"
return
endProcedure tstCompProc
tstCompSyntax: procedure expose m.
call pipeIni
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 $ =
$/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 $. {
$/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 $- ¢
$/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
$/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 3 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'
/*
$=/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
$/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
$/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: $@
$/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: atEnd after 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: atEnd after line 3: .
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' '
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 3 lines: a
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: $**x
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc ' , '$**x'
/*
$=/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', '$$'
$=/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$!
$/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
tstCompWithNew: procedure expose m.
/*
$=/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 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 ': 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 tstCompWithNew
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 sqlConnect , 's'
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
$<>
$<#¢
db ts
DGDB9998 A976
DA540769 A977
$!
$@. csvColRdr()
$** $| 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 , 33 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 classIni
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call tstOStr
call tstOEins
call tstO2Text
call tstF
call tstFWords
call tstFtst
call tstFCat
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvLong
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
call tstDsn2
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstFUnit
call tstfUnit2
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 = asString
. .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 classIni
call tst t, 'tstO'
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
tstOStr: procedure expose m.
/*
$=/tstOStr/
### start tst tstOStr #############################################
. kindOfStri 1
. asString .
. asString - .
. o2String .
abc kindOfStri 1
abc asString abc
abc asString - abc
abc o2String abc
!defg kindOfStri 1
!defg asString defg
!defg asString - defg
!defg o2String defg
TST_STR kindOfStri 0
*** err: TST_STR is not a kind of string but has class TstStr
TST_STR asString 0
TST_STR asString - -
*** err: no method o2String in class TstStr
*** err: o2String did not return
TST_STR o2String 0
lllllll... kindOfStri 1
lllllll... asString llllllllll
lllllll... asString - llllllllll
lllllll... o2String llllllllll
$/tstOStr/
*/
call classIni
o = oMutate(tst_str, classNew('n? TstStr u'))
call mAdd mCut(tstStr, 0), '', 'abc', '!defg', o, left('',500,'l')
call tst t, 'tstOStr'
do ix=1 to m.tstStr.0
e = m.tstStr.ix
f = e
if length(e) > 10 then
f = left(e, 7)'...'
call tstOut t, f 'kindOfStri' oKindOfString(e)
call tstOut t, f 'asString ' strip(left(oAsString(e),10))
call tstOut t, f 'asString -' strip(left(oAsString(e,'-'),10))
call tstOut t, f 'o2String ' strip(left(o2String(e),10))
end
call tstEnd t
return
endProcedure tstOStr
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...!
o2 > tstO2T2=¢f2f=v_o2_f2f =value_o2!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = oMutate('tstO2T1', cl)
o1 = oMutate('tstO2T1', cl)
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'
c2 = classNew('n? TstO2Text2 u f f2f v, v')
o2 = oMutate('tstO2T2', c2)
call mPut o2'.f2f', 'v_o2_f2f'
call mPut o2 , 'value_o2'
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)
call tstOut t, 'o2 >' o2Text(o2 , 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
tstEnvLong: procedure expose m.
call pipeIni
/*
$=/tstEnvLong/
### start tst tstEnvLong ##########################################
before pipeWriteAll
after pipeWriteAll
file out 1010 = comp 1010
$/tstEnvLong/
*/
call tst t, "tstEnvLong"
o = tstFileName('envLong', 'r')
q = time() date()
b = jBuf()
do ix=1 to 100
m.b.buf.ix = ix q
end
m.b.buf.0 = 100
i = jOpen(cat(), '>')
c = 'tstEnvLongC'
m.c.0 = 0
do ix=1 to 10
call jWrite i, 'vor loop' ix
call mAdd c, 'vor loop' ix
call jWriteAll i, b
call maddSt c, b'.BUF'
end
call pipe '+Ff', file(o '::f'), jClose(i)
call tstOut t, 'before pipeWriteAll'
call pipeWriteAll
call tstOut t, 'after pipeWriteAll'
call pipe '-'
p = jOpen(file(o), '<')
do ix = 1 while jRead(p)
if m.c.ix <> m.p then
call tstOut t, ix '<>' m.c.ix '<>' m.p
end
call jClose p
call tstOut t, 'file out' (ix-1) '= comp' m.c.0
call tstEnd t
return
endProcedure tstEndLong
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
$/tstDsn/
$=/tstDsnL/
### start tst tstDsnL #############################################
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 1/5, seqFuenf 2/5, seqFue+
nf 3/5, seqFuenf 4/5, seqFuenf 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 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 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
$/tstDsnL/
*/
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 tstEnd t
if sx & \ m.tst_long then
iterate
call tst t, 'tstDsnL'
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 suf, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn suf, 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
tstDsn2: procedure expose m.
/*
$=/tstDsnEq/
### start tst tstDsnEq ############################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnEq/
$=/tstDsnLng/
### start tst tstDsnLng ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnLng/
$=/tstDsnSht/
### start tst tstDsnSht ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/
p2s= TSTDSNS 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(EINS) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
$/tstDsnSht/
*/
call tstIni
tCnt = 0
cRZ = (m.tst_csmRZ \== '') * 3
if m.tst_long then
cSel = ''
else do /* one with iebCopy one with copyW */
cSel = random(0, 10*(cRz+1) - 1)
cSel = cSel + cSel % 5 + 2 random(0, 2*(cRz+1) - 1) * 6 + 1
say 'tstDsn2 selects' cSel
end
do sx=0 to cRz
sFr = copies(m.tst_csmRz'/', sx >= 2)
sTo = copies(m.tst_csmRz'/', sx // 2)
do fx=1 to 2
ff = substr('FV', fx, 1)
fWr = 1
do ty=1 to 2
tx = 1 + (fx <> ty)
tA = word('::F50 ::V54', tx)
tf = substr(tA, 3, 1)
tA = copies(tA, ff <> tf)
do lx=1 to 3 /* 1 + 2 * (ff = tf) */
tCnt = tCnt + 1
if wordPos(tCnt, cSel) < 1 & cSel <> '' then
iterate
if lx = 1 then do
tq = 'Eq'
end
else if lx = 2 then do
tq = 'Lng'
tA = '::'tf'60'
end
else do
tq = 'Sht'
tA = '::'tf || if(tf=='F', 10, 14)
end
if fWr then do
fWr = 0
fS = tstFileName(sFr'fr'ff'.tstDsnS', 'r')
fP = tstFileName(sFr'fr'ff'.tstDsnP', 'r')
call tstDsnWr fS '::'ff'50', 1
call tstDsnWr fP'(eins) ::'ff'50', 2
end
call tst t, 'tstDsn'tq
say '>>>>> csm/sys from' sFr ff 'to' sTo tf tq tA ,
'<<<<<' tCnt 'ff=tf' (ff=tf)
tS = tstFileName(sTo || tq || tf'.tstDsnS', 'r')
tP = tstFileName(sTo || tq || tf'.tstDsnP', 'r')
call dsnCopy fS, tS tA
call tstOut t, 'seq=' tstDsnR1(tS)
call dsnCopy '-' fP'(eins)', tS tA
call tstOut t, 'p2s=' tstDsnR1(tS)
call dsnCopy fP'(eins)', tP'(zwei)' tA
call tstDsnRL t, tP, 'par='
call dsnCopy fS, tP'(seq)' tA
call dsnCopy fP, tP tA, 'eins>drei'
call dsnCopy fP, tP tA
call tstDsnRL t, tP, 's>*='
call tstEnd t
end
end
end
end
return
endProcedure tstDsn2
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: csm rc=8 .
. e 1: stmt=csmExec allocate SYSTEM(?QZ) DDNAME(MBRLISDD) DATASE+
T('A540769.WK.RXXYY') DISP(SHR) timeout(30) .
. e 2: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 3: CSMSI77E SYSTEM=?QZ,TIMEOUT=30 .
%%%
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;
f(a%(b%3Cc%)d, eins, zwei ) =abinscd;
f(a%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbinef;
f(a@2%(b%3Cc%)d, eins, zwei ) =abei cd;
f(a@2%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbeief;
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'
call tstF1 'a%(b%3Cc%)d'
call tstF1 'a%(b%3Cc%,d%-3Ce%)f'
call tstF1 'a@2%(b%3Cc%)d'
call tstF1 'a@2%(b%3Cc%,d%-3Ce%)f'
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 .
, #0-- --
#a%9c#l<<#r>> <<>>
*#a%-7c .
??empty?? eins
1space eins
, #0-- eins
#a%9c#l<<#r>> << eins>>
*#a%-7c eins .
??empty?? einszwei
1space eins zwei
, #0-- eins, zwei
#a%9c#l<<#r>> << eins zwei>>
*#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, #0-- eins, zwei, drei
#a%9c#l<<#r>> << 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, ', #0-- ' fWords(', #0--' ,subword(ws,1,l))
call tstOut t, '#a%9c#l<<#r>>',
fWords('#a%9c#l<<#r>>' ,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 SZ => 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 SY => GB29X3LV|
1956-01-29-23.34.56.987654 SA => C9233456|
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 sZ => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sY => OM23Q5SI|
2014-12-23-16.57.38 sA => C3165738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
$/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 DZ => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 DY => UG18A0AA|
23450618 DA => B8000000|
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 dZ => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dY => MH24A0AA|
120724 dA => C4000000|
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 EZ => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 EY => UM09A0AA|
09.12.1345 EA => A9000000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.24 eS => 2024-05-31-00.00.00.000000|
31.05.24 es => 2024-05-31-00.00.00|
31.05.24 e => 2024-05-31-00.00.00|
31.05.24 eD => 20240531|
31.05.24 ed => 240531|
31.05.24 eE => 31.05.2024|
31.05.24 ee => 31.05.24|
31.05.24 et => 00.00.00|
31.05.24 eT => 00:00:00.000000|
31.05.24 eZ => OF31|
31.05.24 eM => F3100000|
31.05.24 eH => A00000|
31.05.24 eY => YF31A0AA|
31.05.24 eA => D1000000|
31.05.24 ej => 24152|
31.05.24 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 tZ => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tY => ??01M3LV|
12.34.56 tA => A1123456|
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 TZ => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 TY => ??01X4MG|
23.45.06.784019 TA => A1234506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstYold/
### start tst tstFTstY ############################################
PE25 YS => 2015-04-25-00.00.00.000000|
PE25 Ys => 2015-04-25-00.00.00|
PE25 Y => 2015-04-25-00.00.00|
PE25 YD => 20150425|
PE25 Yd => 150425|
PE25 YE => 25.04.2015|
PE25 Ye => 25.04.15|
PE25 Yt => 00.00.00|
PE25 YT => 00:00:00.000000|
PE25 YZ => ?E25|
PE25 YM => E2500000|
PE25 YH => A00000|
PE25 YY => PE25A0AA|
PE25 YA => C5000000|
PE25 Yj => 15115|
PE25 YJ => 735712|
$/tstFTstYold/
$=/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 MZ => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 MY => ?I23R4XP|
I2317495 MA => C3174950|
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 HZ => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 HY => ??01M3LV|
B23456 HA => A1123456|
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 nZ => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nY => GE23R5UJ|
19560423 17:58:29 nA => C3175829|
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 NZ => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 NY => KM30K2DR|
32101230 10:21:32.456789 NA => D0102132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
$=/tstFTstY/
### start tst tstFTstY ############################################
RF06R2UT YS => 2017-05-06-17.28.39.000000|
RF06R2UT Ys => 2017-05-06-17.28.39|
RF06R2UT Y => 2017-05-06-17.28.39|
RF06R2UT YD => 20170506|
RF06R2UT Yd => 170506|
RF06R2UT YE => 06.05.2017|
RF06R2UT Ye => 06.05.17|
RF06R2UT Yt => 17.28.39|
RF06R2UT YT => 17:28:39.000000|
RF06R2UT YZ => ?F06|
RF06R2UT YM => F0617283|
RF06R2UT YH => B72839|
RF06R2UT YY => RF06R2UT|
RF06R2UT YA => A6172839|
RF06R2UT Yj => 17126|
RF06R2UT YJ => 736454|
$/tstFTstY/
*/
say "current time '%t '" f('%t ') "'%t D'" f('%t D')
say " '%t S'" f('%t S') "'%t t'" f('%t t') "'%t T'" f('%t T')
allOut = 'Ss DdEetTZMHYAjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.24' ,
't12.34.56' ,
'T23.45.06.784019' ,
/* 'YPE25' ,
*/ 'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789',
'YRF06R2UT'
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
tstFUnit2: procedure expose m.
/* b
$=/tstFUnit2/
### start tst tstFUnit2 ###########################################
. 12 = 12 12
. 23k = 23000 23552
34 K = 34000 34816
45 M = 45000000 47185920
567G = 567000000000 608811614208
. 678 = 678
$/tstFUnit2/
*/
call tst t, 'tstFUnit2'
call tstOut t, ' 12 =' fUnit2I('d',' 12 ') fUnit2I('b',' 12 ')
call tstOut t, ' 23k =' fUnit2I('d',' 23k') fUnit2I('b',' 23k')
call tstOut t, '34 K =' fUnit2I('d','34 K ') fUnit2I('b','34 K ')
call tstOut t, '45 M =' fUnit2I('d','45 M') fUnit2I('b','45 M')
call tstOut t, '567G =' fUnit2I('d','567G') fUnit2I('b','567G')
call tstOut t, ' 678 =' fUnit2I('t',' 678 ')
/* t umbauen, funktioniert nicht mit jetztigen Metadaten ||||
call tstOut t, ' 78 s ='fUnit2I('t', ' 78 s ')
call tstOut t, '567G' fUnit2I('t', ' 123 ') */
call tstEnd t
return
endProcedure tstFU
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
tstFUnit: procedure
/*
$=/tstFUnit/
### start tst tstFUnit ############################################
. 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 ==> 0a =-> -0a =+> +0a =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.000a =-> -0.000a =+> +0.000a =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -++++++ =+> +++++++ =b> 16.083E
. 20.987E20 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
$/tstFUnit/
$=/tstFUnitT/
### start tst tstFUnitT ###########################################
. .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 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstFUnitT/ */
call jIni
call tst t, "tstFUnit"
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) ,
'==>' fUnit('d' , word(lst, wx)),
'=->' fUnit('d' , '-'word(lst, wx)),
'=+>' fUnit('d¢+', word(lst, wx)),
'=b>' fUnit('b' , word(lst, wx))
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d7.3' , word(lst, wx)),
'=->' fUnit('d7.3' , '-'word(lst, wx)),
'=+>' fUnit('d7.3¢+', word(lst, wx)),
'=b>' fUnit('b7.3' , word(lst, wx))
end
call tstEnd t
call tst t, "tstFUnitT"
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) ,
'==>' fUnit('t' , word(lst, wx)),
'++>' fUnit('t¢ ', word(lst, wx)),
'-+>' fUnit('t' , '-'word(lst, wx)),
'-->' fUnit('t¢ ', '-'word(lst, wx))
end
call tstEnd t
return
endProcedure tstFUnit
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
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
$/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
$/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
/**** 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 fUnit('d', 3e7)
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
if m.tstTime_ini \== 1 then do
m.tstTime_ini = 1
m.tstTimeNm = ''
aE = right(time('L'), 20, 0)
m.tstTimeLaEla = substr(aE, 12) ,
+ 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
m.tstTimeLaCpu = sysvar('syscpu')
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
nm = strip(m.m.name)
aE = right(time('L'), 20, 0)
aE = substr(aE, 12) + 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
aC = sysvar('syscpu')
if aE < m.tstTimeLaEla | aC < m.tstTimeLaCpu then
call err 'backward time/cpu'
if m.tstTime.nm \== 1 then do
m.tstTime.nm = 1
m.tstTimeNm = m.tstTimeNm nm
m.tstTime.nm.count = 1
m.tstTime.nm.ela = aE - m.tstTimeLaEla
m.tstTime.nm.cpu = aC - m.tstTimeLaCpu
end
else do
m.tstTime.nm.count = m.tstTime.nm.count + 1
m.tstTime.nm.ela = m.tstTime.nm.ela + aE - m.tstTimeLaEla
m.tstTime.nm.cpu = m.tstTime.nm.cpu + aC - m.tstTimeLaCpu
end
/* say left('%%%time' nm, 20) ,
f('%7.3i %9.3i', aC - m.tstTimeLaCpu , aE - m.tstTimeLaEla) ,
f('cum %6i %7.3i %9.3i', m.tstTime.nm.count, m.tstTime.nm.cpu,
, m.tstTime.nm.ela) */
m.tstTimeLaEla = aE
m.tstTimeLaCpu = aC
return
endProcedure tstEnd
tstTimeTot: procedure expose m.
tCnt = 0
tCpu = 0
tEla = 0
say 'tstTimeTotal'
do tx=1 to words(m.tstTimeNm)
nm = word(m.tstTimeNm, tx)
say left(nm, 12) f('%6i %7.3i %9.3i', m.tstTime.nm.count,
, m.tstTime.nm.cpu, m.tstTime.nm.ela)
tCnt = tCnt + m.tstTime.nm.count
tCpu = tCpu + m.tstTime.nm.cpu
tEla = tEla + m.tstTime.nm.ela
end
say left('total', 12) ,
f('%6i %7.3i %9.3i', tCnt, tCpu, tEla)
return
endProcedre tstTimeTot
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'
m.tst_long = 0
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 & c \== '%%%' 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 **************************************************/
}¢--- A540769.WK.REXX(TT) cre=2009-08-17 mod=2016-11-17-13.24.33 A540769 -------
/* rexx */
say eins zwei 567890
say eins zwei drei
exit
m.eins = 'say preting; interpret mk("EINS", "say executing eins")'
say m.eins
interpret m.eins
say m.eins
interpret m.eins
exit
mk: procedure expose m.
parse arg nn, cd
say 'making' nn
m.nn = cd
return cd
say sysvar('sysnode')
exit
call fmtTimeTest
err:
say 'error' arg(1)
exit
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)
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
fmtTimeTest: procedure
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)
say right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)'|'
end
do wx=1 to words(lst)
say right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)'|'
end
return
endProcedure fmtTimeTest
say 'result' result
call abc
say 'result' result
abc: return 'abcReturn'
}¢--- A540769.WK.REXX(TX) cre=2013-12-23 mod=2016-11-11-09.47.49 A540769 -------
/* rexx ****************************************************************
tx: testDriver
as editMacro: tx fun
from tso: tx pdsMbr fun
fun = empty execute unprocessed statements
r clear process flags and execute from beginning
c clear process flags
version from 11.11.16
***********************************************************************/
call errReset 'hI'
call wshIni
m.sql_retOK = 'dne rod'
parse arg oArgs
args = oArgs
if 0 then
oArgs = 'L DSN.MAREC.DBZF.D090702.T175332.JOB101(STAALL)' ,
'001 YMRCO001 rebu wa'
m.dbConn = ''
m.tx_ini = 0
m.tx.isMacro = oArgs == '' & sysVar('sysISPF') = 'ACTIVE'
if m.tx.isMacro then
m.tx.isMacro = adrEdit('macro (oArgs)', '*') == 0
if m.tx.isMacro then do
call adrEdit '(pds) = dataset'
call adrEdit '(mbr) = member'
parse var oArgs o1 o2
if length(o1) > 8 then do
m.tx.isMacro = 0
end
else if length(o1) > 2 then do
args = pds'('o1')' o2
m.tx.isMacro = 0
end
else do
if mbr == '' then
call err 'edit a pds member not' pds
args = pds'('mbr')' oArgs
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call err 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' pds'('mbr')'
call adrEdit 'save', '*'
end
end
end
if args = '' | pos('?', args) > 0 then
exit help()
parse var args dsn fun opts
dsn = dsn2jcl(dsn)
call vPut 'dsn', dsn
call vPut 'pds', dsnSetMbr(dsn)
mbr = dsnGetMbr(dsn)
if mbr = '' | length(mbr) > 7 then
call errHelp 'first arg word not a pds with member <=7:' args
call vPut 'mbr', mbr
call vPut 'mpr', if(length(mbr) <= 5, mbr, left(mbr, 5))
call vPut 'ini', dsnSetMbr(dsn, 'INI')
call vPut 'gen', ''
if abbrev(fun, '-') then do
opts = substr(fun, 2) opts
fun = ''
end
ib = jBuf()
m.tx.inp = ib
m.tx.iBuf = ib'.BUF'
call readDsn dsn, 'M.'m.tx.iBuf'.'
m.tx.comp = comp(ib)
m.tx.save = 0
m.tx.outAdd.0 = 0
if fun = '' then do
call txCont opts
end
else if fun = 'c' then do
call txReset m.tx.iBuf, opts
end
else if fun = 'r' then do
call txReset m.tx.iBuf, opts
call txSave
call readDsn dsn, 'M.'m.tx.iBuf'.'
call txCont opts
end
else
call errHelp 'bad fun' fun 'in args' oArgs
call txSave
call dbConn
exit
dbConn: procedure expose m.
parse arg sub
if m.dbConn = sub then
return
if m.dbConn \== '' then
call sqlDisconnect
if sub \== '' then
call sqlConnect sub
m.dbConn = sub
say 'connected to' sub
return
endProcedure dbConn
sqlProc: procedure expose m.
parse arg inp, pJ72
say sqlProc 'j72' pJ72
call sqlStmts inp, 100, if(pJ72==1, 's')
return
endProcedure sqlProc
txCmpRun: procedure expose m.
parse arg ki, inpDsn, outDsn
say 'txCmpRun' inpDsn '->' outDsn / 0
call compRun ki, file(inpDsn), file(outDsn)
say 'txCmpRun -> ended'
return
endProcedure txCmpRun
/*--- remove all history information from testcase,
so it will restart from scratch next time --------------------*/
txReset: procedure expose m.
parse arg i
z = 0
do y=1 to m.i.0
if pos(firstNE(m.i.y), '-+') > 0 then
iterate
z = z + 1
m.i.z = m.i.y
end
m.tx.save = z \= m.i.0
m.i.0 = z
return
endProcedure txReset
/*--- save testcase member if necessary ------------------------------*/
txSave: procedure expose m.
if m.tx.save = 0 then
return
ib = m.tx.iBuf
if m.tx.save = 1 then do
if \ m.tx.isMacro then do
call writeDsn vGet('dsn'), 'M.'ib'.', , 1
return
end
call adrEdit 'del .zf .zl'
do y=1 to m.ib.0
li = m.ib.y
call adrEdit 'line_after .zl = (li)'
end
call adrEdit 'save'
end
else if m.tx.save = 2 then do
ox = 0
ix = 0
if m.tx.isMacro then do
added = 0
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
call adrEdit 'line_after' (added+ax) '= (li)'
added = added + 1
end
call adrEdit 'save'
end
else do
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
do while ix < ax
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
ox = ox + 1
oo.ox = li
end
do while ix < m.ib.0
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
call writeDsn vGet('dsn'), 'OO.', ox, 1
end
end
else
call err 'implement save' m.tx.save
m.tx.save = 0
return
endProcedure txSave
/*--- return first non Space (Empty) char from str, '' if all spaces -*/
firstNE: procedure expose m.
parse arg str
c1 = verify(str, ' ')
if c1 > 0 then
return substr(str, c1, 1)
return ''
endProcedure firstNE
/*--- continue testcase
maximal cnt steps,
until testcase has to wait or is at end --------------------*/
txCont: procedure expose m.
parse arg cnt
cmp = m.tx.comp
call compBegin cmp
scn = m.cmp.scan
run = ''
one = ''
instr = ''
do forever
inst1 = ''
one = compile(cmp, ':')
if scanEnd(scn) then do
end
else if left(m.scn.src, m.scn.pos-1) <> '' then
call scanErr scn, 'bad text before tx instruction'
else if scanLit(scn, '+', '-') then do
if m.scn.tok == '+' then do
call scanName scanSkip(scn)
if translate(m.scn.tok) <> 'OK' then do
say m.scn.src
return
end
instr = ''
end
call scanNl scn, 1
end
else if scanName(scn) then do
fun = m.scn.tok
if wordPos(translate(fun), 'CREDB MANUAL NOP') < 1 then
call scanErr scn, fun 'is no tx instruction'
inst1 = word(scanPos(scn), 1) fun compExpr(cmp, 's', '=')
end
else
call scanErr scn, fun 'bad tx instruction'
if instr <> '' then do
do rx = 1 to words(run)
call oRun word(run, rx)
end
run = ''
call txIni
parse var instr m.tx.inPos fun rAst
cd = 'res = txFun'fun'('compAst2Rx(cmp, '-', rAst)')'
m.tx.outSta = 0
interpret cd
say 'res' res 'outSta' m.tx.outSta 'from' cd
if m.tx.outSta = 2 then
return
if m.tx.outsta \== 1 then
call err 'bad outSta' m.tx.outSta 'after' code
end
instr = inst1
run = run one
if instr = '' & scanEnd(scn) then
return
end
call err 'no paseran'
endProcedure txCont
txIni: procedure expose m.
if m.tx_ini then
return
call wshRun tx, ':', file(vGet('ini'))
m.tx_ini = 1
return
endProcedure txIni
/*--- output a status line -------------------------------------------*/
txOutSta: procedure expose m.
parse arg op fun, rest
if m.tx.save = 0 then
m.tx.save = 2
else if m.tx.save <> 2 then
call err 'txOutSta but save='m.tx.save
fun = strip(fun)
if op == '+' then do
m.tx.outSta = max(m.tx.outSta,
, 1 + (wordPos(translate(fun), 'RUN WAIT') > 0) )
end
else if op \== '-' then
call err 'bad op' op 'in txOutSta('op fun',' rest')'
call mAdd 'TX.OUTADD', m.tx.inPos op fun strip(rest)
say 'outSta' m.tx.outSta 'after' op fun strip(rest)
return
endProcedure txOutSta
/*--- do nothing and continue-----------------------------------------*/
txFunNop: procedure expose m.
parse arg opts
if vHasKey('nopCount') then
old = vGet('nopCount')
else
old = 0
call txOutSta '= nopCount', old+1
call txOutSta '+ ok', 'nop'
call txOutSta '- nop', 'opts =' opts
call txOutSta '- nop', 'opts =' opts
return 1
endProcedure txFunNop
/*--- Manual action required -----------------------------------------*/
txFunManual: procedure expose m.
parse arg opts
call txOutSta '+ wait', opts
say 'manual <'opts'>'
return 1
endProcedure txFunManual
/*--- creDb: sql creates, date etc. ----------------------------------*/
txFunCreDb: procedure expose m.
parse arg dst pha .
say 'txFunCreDb' dst pha 'ddl' vGet('ddl')
if wordPos(dst, 'src trg') < 1 then
call err 'creDb bad dest should be src or trg not' dst
if pha = '' | verify(pha, '0123456789') > 0 then
call err 'creDb not natural number but' pha
call vPut 'phase' , strip(pha)
call vPut 'env' , dst
call vPut 'dbSys' , vGet(dst'dbSys' )
call vPut 'db' , vGet(dst'db' )
call vPut 'creator', vGet(dst'creator')
call vPut 'cr', vGet(dst'creator')
gen = vGet('gen')
if gen \== '' then
gen = gen'('vGet('mpr')left(dst, 1)pha')'
call pipe '+F', file(gen '::f')
call wshRun tx, '=', file(vGet('ddl'))
call pipe '-'
/* call adrIsp "edit dataset('"gen"')", 4 */
call dbConn vGet('dbSys')
m.sq.ignore.drop = '-204'
j72 = 0
if vHasKey('j72') then
j72 = vGet('j72')
call sqlProc file(gen), j72
call txOutSta '+ ok', 'creDb' gen
return 1
endProcedure txCreDb
/* copy wsh ab hier ???????*/
/* rexx ***************************************************************
wsh: walter's rexx shell version 6.2
interfaces: 1.11.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 -----------------------------------------------------------
27.10.16 walter: nur 1 system in rq2, jTalkRdr, mark sqlClosed
*********/ /*** end of help *******************************************
21.10.16 walter: set current packageSet / path ... ohne immediate
7.10.16 walter: fix redirection Hook mit only < >, fTst
30. 9.16 walter: blkSize fix fuer csmAlloc, csmAppc mit timeout
8. 9.16 walter: redirection hook
6. 9.16 walter: dsnCopy supports different recFM and lRecL
avoid csm errors: mbrList dsn on Sequential,
lrecl < 272 without blksize on rmtOut
12. 8.16 walter: f recursive %( %, %), fTst B,I,Y,Z / comp table deimp
if, else, proc etc. erlaub nl, * Kommentare für % und ^
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 truncat.
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 = 'WSH'
m.myVers = 'v62e 1.11.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.pipeCnt = (out \== '') * 2
if m.wsh.pipeCnt == 2 then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
if isEdit then
call wshEditEnd wsh
do m.wsh.pipeCnt
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'wsh end: pipe.0='m.pipe.0
else if m.err_cleanup <> '\?' | m.tso_ddAll <> '' then
call err 'wsh end: still err cleanups'
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if sysVar(sysNode) = 'RZ0' then
return
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 = '*'
call wshIni
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 wshHookComp( ,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 ***************************************/
/* 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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 = 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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
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 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 ************************************************/
/--- 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 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
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 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 ************************************/
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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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 sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
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"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- 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 */
call csmAppc 'csmASql', , , 4
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
**********************************************************************/
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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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:
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 ******************************************************/
/* 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
call iiIni
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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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.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
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(UT) cre=2016-10-26 mod=2016-10-26-09.51.12 A540769 -------
/* 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(WAR) cre=2016-09-26 mod=2016-11-27-16.03.36 A540769 ------
/* rexx ****************************************************************
synopsis: WAR opt* c <warFile> <ds>+
WAR opt* x <warFile> ( <frPr> <toPr> )*
creates a warFile from a list of datasets and or members of a PDS
or extracts datasets and or members from a warFile,
arguments:
<warfile> DSN of the warfile
<ds> if <ds> is a PDS all members are added,
if a seqential dataset or a member of a PDS it is added
<frPr> <toPr> if no prefix pair is given, all dsn are extracted
to the same name
otherwise the prefix (of a DSN in warfile) is changed
from <frPr> to <toPr>, if no <frPr> matches
the file is not extracted
opt*: 0 or several options from
-c<ds> add new charactest to charset dataset
-s<tst> add member only if ispf-statistics cre or mod
are greater or equal tst (prefix of timestamp in Db2 format
remember: cre is date, mod timestamp
-m<num> split warFile after num MB
***********************************************************************/
parse arg mArg
call errReset 'hi'
rArg = strip(translate(mArg))
m.warCharsetDS = ''
m.warSince = ''
m.warLimit = 5e6
wkLst = 'java jcl plb rexx skels sql wk'
wkPr = '~wk.war'
if pos('?', mArg) > 0 then
return help()
else if rArg = '' then
return errHelp('no args')
else if rArg = 'CWK' then do
m.warLimit = 5e6
do wx=1 to words(wkLst)
w1 = word(wkLst, wx)
call warCreate wkPr'('w1'0)', '~wk.'w1
end
return
end
else if rArg = 'SWK' then do
rArg = '-S2016-10-20 C' wkPr'(u'substr(date('s'),3, 6)'u)'
do wx=1 to words(wkLst)
w1 = word(wkLst, wx)
rArg = rArg '~wk.'w1
end
end
else if rArg = 'XWK' then do
toPr = ''
do wx=1 to words(wkLst)
w1 = word(wkLst, wx)
toPr = toPr 'A540769.WK.'w1 wkPr'.'w1
if w1 = 'java' then
toPr = toPr'::v1000'
end
upper toPr
do wx=1 to words(wkLst)
w1 = word(wkLst, wx)
do cx=1 to length(m.ut_numUc)
d1 = dsn2jcl(wkPr'('w1|| substr(m.ut_numUC, cx, 1)')')
if sysDsn("'"d1"'") <> 'OK' then
leave
call warExtract d1, toPr
end
end
return
end
do while abbrev(rArg, '-')
parse var rArg o1 rArg
if abbrev(o1, '-C') then
m.warCharsetDS = substr(o1,3)
else if abbrev(o1, '-M') then
m.warLimit = substr(o1,3) * 1024 * 1024
else if abbrev(o1, '-S') then
m.warSince = substr(o1,3)
else
call err 'bad opt' o1 'in args' mArg
end
parse var rArg fun war list
if fun == 'C' then
call warCreate war, list
else if fun == 'X' then
call warExtract war, list
else
call errHelp 'war fun='fun 'not supported in args' args
exit
warCreate: procedure expose m.
parse arg m.warDsn, list
m.warCntF = 0
m.warCntL = 0
m.warCntB = 0
m.warDsX = 0
if m.warCharsetDS \== '' then do
m.charSet = ''
call readDsn m.warCharsetDS, cc.
do cx=1 to cc.0
call checkCharset(cc.cx)
end
end
charSetL = length(m.charSet)
call warDsnOC 2
do lx=1 to words(list)
i = dsn2jcl(word(list, lx))
if pos('(', i) > 0 then
call warCreAddLib i
else if pos("<"sysDsn("'"i"(noMbr)'")">" ,
, "<OK> <MEMBER NOT FOUND>") > 0 then
call warCreAddLib i"(*)"
else
call warCreAddSeq i
end
call warDsnOC 1
call warSayAdded
if m.warCharsetDS \== '' & (length(m.charSet) <> charSetL) then do
cy = cc.0
do cZ = charSetL+1 by 20 to length(m.charSet)
cy = cy + 1
cc.cy = 'plus ' substr(m.charset, cZ, 20)
end
call writeDsn m.warCharsetDS, cc., cy, 1
say 'charset' cc.cy
end
return
endProcedure warCreate
warCreAddLib: procedure expose m.
parse arg iDsn
/* open lmId for ispf member statistics */
lmid = lmOpen(iDsn)
if verify(dsnGetMbr(iDsn), '*?', 'm') <= 0 then do
call warCreAddMbr iDsn, lmId
end
else do mx=1 to mbrList(ml, iDsn)
call warCreAddMbr dsnSetMbr(iDsn, m.ml.mx), lmId
end
call lmClose lmid
return
endProcedure warCreAddLib
warCreAddMbr: procedure expose m.
parse arg iDsn, lmId
call adrIsp 'lmmFind dataid('lmid') member('dsnGetMbr(iDsn)')' ,
'stats(yes) noLla'
cre = translate(ZLC4DATE, '-', '/')
if zlm4date = '' then
mod = ''
else
mod = translate(ZLM4DATE'-'zlmTime':'zlmSec, '-.', '/:')
if cre >>= m.warSince | mod >>= m.warSince then
call warCreAddFile iDsn, 'cre='cre 'mod='mod zlUser
/* else
say 'not adding' iDsn 'tooOld cre='cre 'mod='mod */
return
endProcedure warCreAddMbr
warCreAddFile: procedure expose m.
parse arg m.iDsn, hd
if m.warFiB > m.warLimit then
call warDsnOC 3
call dsnAlloc 'dd(iDD)' m.iDsn
h.1 = '}¢---' strip(m.iDsn hd) '---'
if length(h.1) < 80 then
h.1 = left(h.1, 80, '-')
if m.warCharsetDS \== '' then
call checkCharset h.1
call warWriteDD h., 1
lc = 1
bc = length(h.1)
do while readDD(iDD, i., 1000)
lc = lc + i.0
do ix=1 to i.0
li = i.ix
if abbrev(li, '}¢') then
li = '}¢\'substr(li, 3)
li = strip(li, 't')
if m.warCharsetDS \== '' then
call checkCharSet(li)
if li == '' then
i.ix = ' '
else
i.ix = li
bc = bc + length(i.ix)
end
call warWriteDD i.
end
call tsoClose iDD
call tsoFree iDD
m.warCntF = m.warCntF + 1
m.warCntL = m.warCntL + lc
m.warFiB = m.warFiB + bc
if m.warCntF // 50 = 0 then
call warSayAdded
return
endProcedure warCreAddFile
warCreAddFile22: procedure expose m.
parse arg m.iDsn, hd
call dsnAlloc 'dd(iDD)' m.iDsn
h.1 = left('}¢---' strip(m.iDsn hd)' ', max(80, length(hd)+16),'-')
call warWriteDD h., 1
lc = 1
bc = length(h.1)
pat = 'SELECT GRANT DELETE INSERT DROP ALTER REPLACE TRUNCATE' ,
'UPDATE CREATE RENAME DESCRIBE FROM INTO TABLE DATABASE' ,
'INDEX VIEW UNION PHP ADMIN CATALOG CATEGORY SAVE STATS RX',
'CSS 1=1 TILE MAIL KEY OP SETTING OPEN PAGE EXTRA SETTI SQL' ,
'REQUEST URI'
tF = ' 'm.ut_rxid
tx = 35
tT = substr(tF, tx+1)left(tF, tx)
do while readDD(iDD, i., 1000)
lc = lc + i.0
do ix=1 to i.0
li = i.ix
if abbrev(li, '}¢') then
li = '}¢\'substr(li, 3)
li = strip(li, 't')
li = translate(li, tT, tF)
/* lu = translate(li)
do px=1 to words(pat)
do forever
py = pos(word(pat, px), lu)
if py < 1 then
leave
li = insert('+', li, py+0)
lu = insert('+', lu, py+0)
end
end
*/ if li == '' then
i.ix = ' '
else
i.ix = li
bc = bc + length(i.ix)
end
call warWriteDD i.
end
call tsoClose iDD
call tsoFree iDD
m.warCntF = m.warCntF + 1
m.warCntL = m.warCntL + lc
m.warFiB = m.warFiB + bc
if m.warCntF // 10 = 0 then
call warSayAdded
return
endProcedure warCreAddFile22
warSayAdded: procedure expose m.
if m.warCharsetDS \== '' then
cm = ' charset' length(m.charset)','
else
cm = ''
say m.warCntF 'files' m.warCntL 'lines,' ,
(m.warCntB+ m.warFiB) 'bytes,'cm ,
m.iDsn 'added to' m.tso_dsn.warDD
return
warDsnOC: procedure expose m.
parse arg oc
if oc // 2 == 1 then do
m.warCntB = m.warCntB + m.warFiB
call tsoClose warDD
call tsoFree warDD
end
if oc >= 2 then do
m.warFiB = 0
m.warDsX = m.warDsX + 1
if m.warLimit < 9e99 then do
if m.warDsX > length(m.ut_numUc) then
call err 'overflow' m.warDsX
m.warDsn = overlay(substr(m.ut_numUc, m.warDsX, 1),
, m.warDsn, length(m.warDsn) - 1)
end
call dsnAlloc m.warDsn 'dd(warDD) ::v10000'
call tsoOpen warDD, 'w'
end
return
endProcedure warDsnOC
warWriteDD:
call writeDD warDD, arg(1), arg(2)
return
endSubroutine warWriteDD
warExtract: procedure expose m.
parse upper arg m.warDsn, frTo
parse value dsnAlloc('dd(warDD)' m.warDsn) with frDD frFr
to.1 = ''
do fx=1
fr.fx = word(frTo, 2*fx-1)
if fr.fx = '' then
leave
parse value word(frTo, 2*fx) with toD ':' toAt.fx
if toD = '' then
call err 'incomplete pair' fx':' frTo
if toAt.fx <> '' then
toAt.fx = ':'toAt.fx
else
toAt.fx = '::f'
to.fx = dsn2jcl(toD)
end
fr.0 = max(1, fx-1)
cL = 0
cF = 0
toDD = ''
m.warExt.lmDsn = ''
do while readDD(frDD, i.)
do ix=1 to i.0
if \ abbrev(i.ix, '}¢') then
iterate
if abbrev(i.ix, '}¢\') then do
i.ix = '}¢'substr(i.ix, 4)
iterate
end
if toDD <> '' then
toDD = warExtWriClo(toDD, toFx, ix-1,toN,cre,mod,usr)
parse var i.ix sepB dsn cre mod usr sepE
if (sepB == '}¢---' & abbrev(cre, 'cre=') ,
& abbrev(mod, 'mod=') & abbrev(sepE, '---')) then
nop
else if (sepB == '}¢---' & cre == 'cre=' ,
& (abbrev(usr, '---') | abbrev(sepE, '---'))) then
cre = ''
else
call err 'bad header' i.ix '#' || (cL+ix) 'in' m.warDsn
cF = cF + 1
do fx=1
if fx > fr.0 then do
say 'ignore' cF '#' || (cL + ix) dsn cre mod usr
leave
end
if abbrev(dsn, fr.fx) then do
toN = to.fx || substr(dsn, length(fr.fx)+1)
say 'extract' cF '#' || (cL + ix) dsn cre mod usr,
'=>' toN
toDD = dsnAlloc('dd(extDD)' toN toAt.fx)
m.warExt.oCnt = -1
toFx = ix+1
leave
end
end
end
if toDD <> '' then
call warExtWri toDD, toFx, i.0
toFx = 1
cL = cL + i.0
end
if toDD <> '' then
toDD = warExtWriClo(toDD, toFx, i.0 ,toN,cre,mod,usr)
if m.warExt.lmDsn <> '' then
call lmClose m.warExt.lmId
say cF 'file,' cL 'lines in' m.warDsn
call tsoClose frDD
call tsoFree frFr
return
endProcedure warExtract
warExtWri: procedure expose m. i.
parse arg toDD toFr, fx, tx
if m.warExt.oCnt < 0 then do
call tsoOpen toDD, 'w'
m.warExt.oCnt = 0
end
if fx = 1 then do
call writeDD toDD, i., tx
m.warExt.oCnt = m.warExt.oCnt + tx
end
else do
iy = 0
do ix=fx to tx
iy = iy + 1
y.iy = i.ix
end
call writeDD toDD, y., iy
m.warExt.oCnt = m.warExt.oCnt + iy
end
return
endProcedure warExtWri
warExtWriClo: procedure expose m. i.
parse arg toDD toFr, fx, tx, dsn, cre, mod, usr
call warExtWri toDD toFr, fx, tx
call tsoClose toDD
call tsoFree toFr
if cre = '' then
return ''
if m.warExt.lmDsn <> dsnSetMbr(dsn) then do
if m.warExt.lmDsn <> '' then
call lmClose m.warExt.lmId
m.warExt.lmDsn = dsnSetMbr(dsn)
m.warExt.lmId = lmOpen(m.warExt.lmDsn)
end
/* adrIsp 'lmmStats dataid('lmid') member(wsh) createD4(1908/04/01)',
'modDate4(2122/05/31) modTime(23:24:25) user(MyUser7)' */
st = 'curSize('m.warExt.oCnt') user('usr')' ,
'created4('translate(substr(cre, 5, 10), '/', '-')')' ,
'modDate4('translate(substr(mod, 5, 10), '/', '-')')' ,
'modTime('translate(substr(mod, 16, 8), ':', '.')')'
call adrIsp 'lmmStats dataid('m.warExt.lmid')' ,
'member('dsnGetMbr(dsn)')' st
return ''
endProcedure warExtWriClo
checkCharSet: procedure expose m.
parse arg li
do forever
cx = verify(li, m.charset)
if cx = 0 then
return
m.charSet = m.charSet || substr(li, cx, 1)
end
endProcedure checkCharSet
lmOpen: procedure expose m.
parse arg dsn
call adrIsp "lmInit dataid(lmid) dataset('"dsnSetMbr(dsn)"')"
call adrIsp 'lmOpen dataid('lmid')'
return lmid
endProcedure lmOpen
lmClose: procedure expose m.
parse arg lmid
call adrIsp 'lmClose dataid('lmid')'
call adrIsp 'lmFree dataid('lmid')'
return
endProcedure lmClose
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"¢"pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse 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 ***************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(WK) cre=2016-10-25 mod=2016-10-25-09.23.04 A540769 -------
/* rexx allocate A540769.wk libraries
copy to wk.clist, then tso ex wk works everywhere ----*/
parse arg a
if a = '' then
a = wk
address tso "exec 'A540769.wk.rexx(alib)' '"a"'"
exit
}¢--- A540769.WK.REXX(WSH) cre=2016-07-11 mod=2016-11-14-08.17.36 A540769 ------
/* rexx ***************************************************************
wsh: walter's rexx shell version 6.2
interfaces: 1.11.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 -----------------------------------------------------------
1.11.16 walter: JRWLazy.jWriteSt wStem zuweisen, do in sqlUpdate entfernt
*********/ /*** end of help *******************************************
27.10.16 walter: nur 1 system in rq2, jTalkRdr, mark sqlClosed
21.10.16 walter: set current packageSet / path ... ohne immediate
7.10.16 walter: fix redirection Hook mit only < >, fTst
30. 9.16 walter: blkSize fix fuer csmAlloc, csmAppc mit timeout
8. 9.16 walter: redirection hook
6. 9.16 walter: dsnCopy supports different recFM and lRecL
avoid csm errors: mbrList dsn on Sequential,
lrecl < 272 without blksize on rmtOut
12. 8.16 walter: f recursive %( %, %), fTst B,I,Y,Z / comp table deimp
if, else, proc etc. erlaub nl, * Kommentare für % und ^
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 truncat.
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 = 'WSH'
m.myVers = 'v62e 1.11.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.pipeCnt = (out \== '') * 2
if m.wsh.pipeCnt == 2 then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
if isEdit then
call wshEditEnd wsh
do m.wsh.pipeCnt
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'wsh end: pipe.0='m.pipe.0
else if m.err_cleanup <> '\?' | m.tso_ddAll <> '' then
call err 'wsh end: still err cleanups'
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if sysVar(sysNode) = 'RZ0' then
return
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 = '*'
call wshIni
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 wshHookComp( ,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 ***************************************/
/* 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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 = 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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
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 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 ************************************************/
/--- 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 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
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 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 ************************************/
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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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 sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
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"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- 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 */
call csmAppc 'csmASql', , , 4
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
**********************************************************************/
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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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:
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 ******************************************************/
/* 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
call iiIni
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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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.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
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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(WSHCOPY) cre=2016-10-26 mod=2016-10-26-09.51.11 A540769 ---
/* 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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 ************************************************/
}¢--- A540769.WK.REXX(WSHTUT00) cre=2010-12-29 mod=2016-11-28-11.00.20 A540769 ---
$#=
$=dbSys=DBOL
$=db=DA540769
$=ts=A977A
//P02 EXEC PGM=DSNUTILB,
// PARM='$dbSys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.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 20161128 11:00:19
//P02 EXEC PGM=DSNUTILB,
// PARM='DBOL,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBOL.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)
PARALLEL
SHRLEVEL CHANGE
$#out 20161127 15:26:47
//P02 EXEC PGM=DSNUTILB,
// PARM='DBOL,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBOL.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)
PARALLEL
SHRLEVEL CHANGE
$#out 20160120 09:58:00
//P02 EXEC PGM=DSNUTILB,
// PARM='DBOL,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBOL.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)
PARALLEL
SHRLEVEL CHANGE
$#out 20110208 09:13:15
}¢--- A540769.WK.REXX(WSHTUT05) cre=2016-11-28 mod=2016-11-28-13.35.03 A540769 ---
$#=
$>. fEdit()
$= dbSys = DP4G
db ts
DGDB9998 A976
A977
DA540769
S976
S975
$|
$@. csvColRdr()
$|
$@ aDb = '?'
$= sx = 0
$@<~wk.jcl(jc)
$forWith i $@¢
if $db <> '' & aDb <> $db then $@=¢
$@stepFinish
$@ aDb = $db
$= sx =- $sx + 1
//**************** step $sx: db=$db
//S$sx EXEC PGM=DSNUTILB,
// PARM='$dbSys,A540769W.FULCOPY'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
OPTIONS EVENT(ITEMERROR, SKIP)
LISTDEF LST
$! else $@:¢ db =- aDb $!
if $ts <> '' then $@=¢
INCLUDE TABLESPACE $db.$ts PARTLEVEL $!
$!
$@stepFinish
$proc $@=/stepFinish/
$@ if $sx < 1 then return
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/stepFinish/
$#out 20161128 13:33:47
}¢--- A540769.WK.REXX(WSHTUT06) cre=2016-11-28 mod=2016-11-28-13.36.05 A540769 ---
$#@
$@. csvColRdr()
$|
$@ aDb = '?'
$= sx = 0
$@<~wk.jcl(jc)
$forWith i $@¢
if $db <> '' & aDb <> $db then $@=¢
$@stepFinish
$@ aDb = $db
$= sx =- $sx + 1
//**************** step $sx: db=$db
//S$sx EXEC PGM=DSNUTILB,
// PARM='$dbSys,A540769W.FULCOPY'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
OPTIONS EVENT(ITEMERROR, SKIP)
LISTDEF LST
$! else $@:¢ db =- aDb $!
if $ts <> '' then $@=¢
INCLUDE TABLESPACE $db.$ts PARTLEVEL $!
$!
$@stepFinish
$proc $@=/stepFinish/
$@ if $sx < 1 then return
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/stepFinish/
}¢--- A540769.WK.REXX(WSHTUT07) cre=2016-11-28 mod=2016-11-28-13.38.15 A540769 ---
$#=
$>. fEdit()
$= dbSys = DP4G
db ts
DGDB9998 A976
A977
DA540769
S976
S975
$|
$@.^¢compile $<~wk.rexx(wshTut06) $!
$#out 20161128 13:37:56
$#out 20161128 13:37:45
$#out 20160303 09:53:37
}¢--- A540769.WK.REXX(WSHTUT08) cre=2010-12-31 mod=2016-11-28-13.39.33 A540769 ---
$#%
>. fEdit()
= dbSys = DP4G
= util = $copy $runstats
dbTs DGDB9998 A976
ts A977
db DA540769
ts S976
dbTs DA540769 S975
if ${?woDb} then
finish
$proc $@/db/ $** default db ----------------
$arg svDb
$/db/
$proc $@/ts/ $** add ts --------------------
$arg aTs
$@% dbTs $svDb $aTs
$/ts/
$proc $@/dbTs/ $** add db ts -----------------
$arg aDb aTs rest
if \ ${?woDb} then $@¢ $** first call create jobHeader
$@job
$@% step $aDb
$! else if $woDb <> $aDb then $@¢ $** finish old DB start new DB
$@finish
$@% step $aDb
$!
t = ' INCLUDE TABLESPACE' $aDb'.'$aTs
$$- t $** add to list lTs
call jWrite $lPa, t 'PARTLEVEL' $** add to list lPa
$/dbTs/
$proc $@:/job/ $** job header ----------------
stepNo = 0
jobName = A540769W
lPa =- jBuf()
@<~wk.jcl(jc)
$/job/
$proc $@=/step/ $** jcl utility step ----------
$arg svDb
$arg woDb
$= stepNo =- right($stepNo + 1, 3, 0)
$@ call jOpen $lPa, '>'
//*--- for db $woDb -----------------------------------------------
//UTI$stepNo EXEC PGM=DSNUTILB,PARM='$dbSys,$jobName.UTILS'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
OPTIONS EVENT(ITEMERROR, SKIP)
LISTDEF LTS
$/step/
$proc $@=/finish/ $** finish current step -------
LISTDEF LPA
$@ call jClose $lPa
$@<.lPa
$do ux=1 to words($util)
$@. word($util,ux)
$/finish/
$proc $@=/copy/ $** copy ----------------------
COPY LIST LPA COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/copy/
$proc $@=/runstats/ $** runstats ------------------
RUNSTATS TABLESPACE LIST LTS
SHRLEVEL CHANGE
TABLE USE PROFILE
TABLESAMPLE SYSTEM AUTO
$/runstats/
$#out 20161128 12:41:11
}¢--- A540769.WK.REXX(WSHTUT09) cre=2010-12-31 mod=2016-11-28-13.39.45 A540769 ---
$#%
>. fEdit()
= dbSys = DP4G
= util = $copy $runstats
dbTs DGDB9998 A976
ts A977
db DA540769
ts S976
dbTs DA540769 S975
if ${?woDb} then
finish
ct @ y = $.^¢compile $<~wk.rexx(wshTut08) $!
}¢--- A540769.WK.REXX(WSHTUT31) cre=2016-11-26 mod=2016-11-27-10.20.22 A540769 ---
$#=
--- primary ---
string mit apostroph $'string $ "q" ''a'' '
string mit quote $"string $ ""q"" 'a' "
$= n1 = eins
variable $n1 Oder
mit {} ${n1}Oder
$= i1 = 1
mit {expression} ${n$i1} geschachtelt $'n$i1'=n$i1
block to string $-¢rexx 'string' (3+1)$!
mehere Zeilen $-¢rexx 'zeile' eins
'zeile zwei' $!
block to object $.¢rexx 'string' (3+2)$!
block to object $.-¢rexx 'string' (3+3)$!
mit operatoren $.-.-n1
proc $-f1
runReturn $-^f1
runOutput $-%f1
run block $.-@¢$$ n1=$n1 $$ zwei$!
$proc $@/f1/
$$ start of function f1
return 'return from f1, n1='$n1
$/f1/
$#out 20161127 10:20:07
--- primary ---
string mit apostroph string $ "q" 'a'
string mit quote string $ "q" 'a'
variable eins Oder
mit {} einsOder
mit {expression} eins geschachtelt n$i1=n1
block to string REXX string 4
mehere Zeilen REXX zeile EINS zeile zwei
block to object REXX string 5
block to object !REXX string 6
mit operatoren !eins
proc O.178.1
start of function f1
runReturn return from f1, n1=eins
runOutput start of function f1
run block !n1=eins zwei
$#out 20161126 10:48:01
}¢--- A540769.WK.REXX(WSHTUT32) cre=2016-11-26 mod=2016-11-27-10.21.23 A540769 ---
$#@
$$ --- expression ---
$=n1=eins
$$# # konstanter text ohne $ bearbeitung n1=$n1
$$^ f1 = ^ runReturn mit argumenten
$$% f1 = % runOutput
$$= = sekeleton mit primaries n1=$n1 $-¢2*3*4$!
$$- '- rexx string' mit primaries 'n1='$n1 $-¢2*3*4$!
$$. '. rexx objects' mit primaries 'n1='$n1 $-¢2*3*4$!
$proc $@/f1/
$arg aa
$$ start f1 aa=$aa
$$ f1 returning
return $aa 'from return of f1'
$/f1/
$#out 20161127 10:20:50
--- expression ---
# konstanter text ohne $ bearbeitung n1=$n1
start f1 aa=^ runReturn mit argumenten
f1 returning
^ runReturn mit argumenten from return of f1
start f1 aa=% runOutput
f1 returning
= sekeleton mit primaries n1=eins 24
- rexx string MIT PRIMARIES n1=eins 24
. rexx objects MIT PRIMARIES n1=eins 24
$#out 20161126 11:07:32
}¢--- A540769.WK.REXX(WSHTUT33) cre=2016-11-26 mod=2016-11-27-10.21.48 A540769 ---
$#@
$$ --- block ---
$@=¢block1 mit ¢! kind =, expressionLine
$$ output statement in block1 $!
$@¢call out 'block2 mit ¢! kind @, expressionLine mit call out'
$$ output statement in block2 $!
$@-/block3/'block3 benannt /name/ ... /name/ kind -, expressionLine'
$$ output statement in block3 $/block3/
$@#/block4/block4 benannt /name/ ... /name/ kind #, expressionLine
$$ output statement in block4 $/block4/
$/block4/
$@^/block5/$$ block5 kind ^, output statement
f1 argument fuer f1 $/block5/
$@%/block6/$$ block6 kind %, output statement
f1 argument fuer f1 $/block6/
$@:/block7/ vv=block7
do i=71 to 72 $$ block7 vv=$vv i=$i $/block7/
$proc $@/f1/ $arg aa
$$ f1 start aa=$aa
return 'return f1('$aa')'
$/f1/
$#out 20161127 10:21:42
--- block ---
block1 mit ¢! kind =, expressionLine
output statement in block1
block2 mit ¢! kind @, expressionLine mit call out
output statement in block2
block3 benannt /name/ ... /name/ kind -, expressionLine
output statement in block3
block4 benannt /name/ ... /name/ kind #, expressionLine
$$ output statement in block4 $/block4/
block5 kind ^, output statement
f1 start aa=argument fuer f1
return f1(argument fuer f1)
block6 kind %, output statement
f1 start aa=argument fuer f1
block7 vv=block7 i=71
block7 vv=block7 i=72
$#out 20161126 12:16:52
}¢--- A540769.WK.REXX(WSHTUT34) cre=2016-11-26 mod=2016-11-27-10.23.42 A540769 ---
$#@
$$ --- operators* (block or primary or expression) ---
$=n1=eins
$$-n1
$$.f1
$$^f1
$$¢block
$$zwei$!
$$^ f1 mit arg
$$n1=$n1
$$- '- n1='$n1
$@¢ call out '@ run: 1. run block with kind @' $!
$$ 2. run object, e.g. proc
$@p2
$@% p2 3. run proc p2 with args - expression not primary|
$proc $@/f1/ $arg aa $@ return 'return f1('$aa')' $/f1/
$proc $@/p2/ $arg aa $$ start p2($aa) $/p2/
$#out 20161127 10:23:40
--- operators* (block or primary or expression) ---
eins
O.176.1=¢ORun176!
return f1()
block zwei
return f1(mit arg)
n1=eins
- n1=eins
@ run: 1. run block with kind @
2. run object, e.g. proc
start p2()
start p2(3. run proc p2 with args - expression not primary|)
$#out 20161126 14:47:10
--- operators* (block or primary or expression) and run ---
eins
O.176.1=¢ORun176!
return f1()
block zwei
return f1(mit arg)
n1=eins
- n1=eins
@ run: 1. run block with kind @
2. run object, e.g. proc
start p2()
start p2(3. run proc p2 with args - expression not primary|)
$#out 20161126 14:46:29
}¢--- A540769.WK.REXX(WSHTUT35) cre=2016-11-26 mod=2016-11-27-10.24.11 A540769 ---
$#@
$$ --- statement ---
$$ output $'$$'
$=v1= assignment1 default kind =
$$ v1=$v1
$=v2=- assignment2 'rexx string' (3*4)
$$ v2=$v2
$=/v3/assignment3 mit
named block$/v3/
$$ v3=$v3
$#:
v4= mit kind : braucht es kein $'$='
$$ v4=$v4
$@¢ call out 'run statement @: 1. execute rexx block' $!
$$ 2. define proc, @ run proc
$@f1
$@% f1 = @% run proc with arguments
$$ ct execute at compile time, ctVar=$ctVar
$ct ctVar = ctVar assigned at compileTime
$do i=35 to 36 $$ do loop i=$i i**2=$-¢$i**2$!
$proc $@/f1/ $arg a1 $$ start proc f1 arg=$a1 $/f1/
$#out 20161127 10:24:06
--- statement ---
output $$
v1=assignment1 default kind =
v2=ASSIGNMENT2 rexx string 12
v3=assignment3 mit named block
v4=mit kind : braucht es kein $=
run statement @: 1. execute rexx block
2. define proc, @ run proc
start proc f1 arg=
start proc f1 arg=@% run proc with arguments
ct execute at compile time, ctVar=ctVar assigned at compileTime
do loop i=35 i**2=1225
do loop i=36 i**2=1296
$#out 20161126 14:51:13
}¢--- A540769.WK.REXX(WSHTUT36) cre=2016-11-26 mod=2016-11-27-10.24.50 A540769 ---
$#:
$$ --- 8 kinds ---
@#¢# only text no primaries no statments $=v= kind# $v $!
$!
@=¢$= v = kindText #
= skeleton with primaries and statments with $'$' v=$v$!
@-¢$= v = kindString -
'- rexx expression yielding string'
' with' primaries and statments with $'$' 'v='$v$!
@.¢$= v = kindObject .
'. rexx expression yielding object (address)'
' with' primaries and statments with $'$' 'v='$v$!
@¢$= v = kindExe @
call out '@ rexx statements' ,
'(with rexx continuation)'
call out ' with primaries' and wshStatments with $'$' 'v='$v$!
@:¢v = kindWsh :
$$ : wshStatements only, no $'$' needed,
$$ $' no' primaries, no expressions v=$v$!
@%¢= v = kindRun %
myOut = % run with arguments,
myOut $-' wshStmts without $', no primaries, no expressions v=$v$!
@^¢= v = kindFunRet ^
myRet = ^ fun returnValue with arguments,
myRet $' wshStmts without $', no primaries, no expressions v=$v$!
$proc myOut $@¢ $arg a $$ $a $!
$proc myRet $@¢ $arg a $@ return $a $!
$#out 20161127 10:24:47
--- 8 kinds ---
# only text no primaries no statments $=v= kind# $v $!
= skeleton with primaries and statments with $ v=kindText #
- rexx expression yielding string
with PRIMARIES AND STATMENTS WITH $ v=kindString -
. rexx expression yielding object (address)
with PRIMARIES AND STATMENTS WITH $ v=kindObject .
@ rexx statements (with rexx continuation)
with primaries AND WSHSTATMENTS WITH $ v=kindExe @
: wshStatements only, no $ needed,
no primaries, no expressions v=kindWsh :
% run with arguments,
wshStmts without $, no primaries, no expressions v=kindRun %
^ fun returnValue with arguments,
wshStmts without $, no primaries, no expressions v=kindFunRet ^
$#out 20161126 16:41:02
}¢--- A540769.WK.REXX(WSHTUT37) cre=2016-11-26 mod=2016-11-27-12.33.52 A540769 ---
$#@
$$ --- file and pipe ---
$= dsn = ~tst.wshtut(t36) ::f
$=n1=eins
$$ write to dsn
$<>
$>~tst.wshtut(t36) ::f
$$ zeile eins n1=$n1
$$ zeile zwei
$<>
$<~tst.wshtut(t36) ::f
$$ read from dsn
call pipeWriteAll
$<>
$$ copy dsn to buffer
$= b =. jBuf()
$<>
$<~tst.wshtut(t36) ::f
$>.b
$for i $$ fromDsn $i
$|
$$ vorher
cc = 0
$for i $@¢
cc = cc + 1
$$ from pipe $-¢cc$!: $i
$!
$$ nachher
$<>
$$ write buffer
call pipeWriteAll $b
$$ use single reads from buffer
$<>
$<.b
$do while in() $@¢
q = m.in
if ${>abc} then
q = q '{<='left($abc, 20)
ii = m.j.in
if jRead(ii) then
q = q 'jRead='left(m.ii, 20)
$$- q
$!
$#out 20161127 12:33:47
--- file and pipe ---
write to dsn
read from dsn
zeile eins n1=eins
zeile zwei
copy dsn to buffer
write buffer
vorher
from pipe 1: fromDsn zeile eins n1=eins
from pipe 2: fromDsn zeile zwei
nachher
use single reads from buffer
vorher {<=from pipe 1: fromDsn jRead=from pipe 2: fromDsn
nachher
$#out 20161127 12:29:04
}¢--- A540769.WK.REXX(WSHTUT38) cre=2016-11-26 mod=2016-11-27-13.37.50 A540769 ---
$#@
$$ --- object ---
$= strich = ----------
$<>
$withNew $@:¢fA=aha $=fB=feld B $!
$withNew $@:¢fA=aZwei $=fB=feld B 2 $!
$|
$forWith i $@¢
$$- o2Text($i) $strich
$$ via $'$i' fA=${i&fA} fB=${i&fB}
o = $i
fldA = 'fA'
fldB = 'fB'
$$- 'rexx' fldA'='m.o.fldA fldB'='m.o.fldB
$$ with fA=$fA fB=$fB
$!
$$ column table to objectBuffer $strich
$<>
$= b =. jBuf()
$@=¢
eins zwei drei
1 a 1 eins
2 b 2 zwei
3 drei 3
$!
$| $@. csvColRdr()
$>.b
$<>
$$ pipeWriteAll buffer $strich
call pipeWriteAll $b
$<>
$$ tabulate buffer $strich
call fTabAuto $<.b
$#out 20161127 13:37:48
--- object ---
O.177.1=¢fA=aha fB=feld B! ----------
via $i fA=aha fB=feld B
rexx fA=aha fB=feld B
with fA=aha fB=feld B
O.177.2=¢fA=aZwei fB=feld B 2! ----------
via $i fA=aZwei fB=feld B 2
rexx fA=aZwei fB=feld B 2
with fA=aZwei fB=feld B 2
column table to objectBuffer ----------
pipeWriteAll buffer ----------
O.188.1=¢eins=1 zwei=a 1 drei=eins!
O.188.2=¢eins=2 zwei=b 2 drei=zwei!
O.188.3=¢eins=3 zwei= drei=drei 3!
tabulate buffer ----------
e zwei drei
1 a 1 eins
2 b 2 zwei
3 drei 3
$#out 20161127 13:37:23
}¢--- A540769.WK.REXX(WSHTUT39) cre=2016-11-26 mod=2016-11-27-13.14.57 A540769 ---
$#@
$$ --- sql ---
call sqlConnect 'rzz/de0g'
$= nL = 'SYSPACK%'
$= r3 = 'AGE' ,'DEP', 'TMT'
$<>
$<=¢
select creator cr, name tb, type
from sysibm.sysTables
where creator = 'SYSIBM' and name like $nL
and right(strip(name), 3) in ($r3)
;
select current timestamp now, current server from sysibm.sysDummy1
$!
call sqlStmts
$<>
$<=¢
select creator cr, name tb
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSPACK%'
and type = 'T'
and right(strip(name), 3) in ('AGE' ,'DEP', 'TMT')
$!
$@. sqlRdr()
$|
$=p =- ' '
$forWith $@=¢
$p select count(*), '$TB' table from $CR.$TB
$=p =- 'union all'
$!
$| call sqlStmts
$#out 20161127 12:35:55
--- sql ---
CR TB T
SYSIBM SYSPACKAGE T
SYSIBM SYSPACKDEP T
SYSIBM SYSPACKSTMT T
SYSIBM SYSPACKSTMT_STMT X
4 rows fetched: select creator cr, name tb, type from sysibm.sysTables whe...
NOW COL2
2016-11-27-12.35.56.589742 CHROI00ZDE0G
1 rows fetched: select current timestamp now, current server from sysibm.s...
COL1 TABLE
266692 SYSPACKAGE
5921451 SYSPACKDEP
6450368 SYSPACKSTMT
3 rows fetched: select count(*), 'SYSPACKAGE' table from SYSIBM .SYSPACKAG...
$#out 20161127 12:34:38
}¢--- A540769.WK.REXX(WSHTUT40) cre=2016-11-27 mod=2016-11-27-14.34.24 A540769 ---
$#@
$$ --- operator .-<@|?%^ ---
$$ . 2object $..-'eins' $..@=¢zwei$!
$= v3 =.-= drei
$$ - 2string $-v3 $.v3 $--..v3 $-=¢vier
fuenf$!
$$- '< 2file' className(objClass($.<-=¢~wk.rexx(wsh)$!))
$=r=.@-¢fuenf time()$!
$$- '@ 2run ' className(objClass($r)) 'run='$-%r
$<> $<.<#¢ginge auch mit $<=¢
sechs
$!
call pipeWriteAll
$<>
$$ | singleton $-|=¢sieben $!
$$ ? 0or1 $-?=¢acht $!
$$ % runOut $-%p1
$$ ^ runRet $-^p1
$proc p1 $@¢$$ p1 output $@ return 'p1 returns'$!
$<>
$#out 20161127 14:33:32
--- operator .-<@|?%^ ---
. 2object !eins O.176.1
- 2string !drei !drei drei vier fuenf
< 2file File
@ 2run ORun178 run=FUENF 14:33:32
ginge auch mit $<=¢
sechs
| singleton sieben
? 0or1 acht
% runOut p1 output
p1 output
^ runRet p1 returns
$#out 20161127 14:25:10
}¢--- A540769.WK.REXX(WST) cre=2016-08-08 mod=2016-11-11-09.47.05 A540769 ------
/* rexx ***************************************************************
wsh: walter's rexx shell version 6.2
interfaces: 1.11.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 -----------------------------------------------------------
1.11.16 walter: JRWLazy.jWriteSt wStem zuweisen, do in sqlUpdate entfernt
*********/ /*** end of help *******************************************
27.10.16 walter: nur 1 system in rq2, jTalkRdr, mark sqlClosed
21.10.16 walter: set current packageSet / path ... ohne immediate
7.10.16 walter: fix redirection Hook mit only < >, fTst
30. 9.16 walter: blkSize fix fuer csmAlloc, csmAppc mit timeout
8. 9.16 walter: redirection hook
6. 9.16 walter: dsnCopy supports different recFM and lRecL
avoid csm errors: mbrList dsn on Sequential,
lrecl < 272 without blksize on rmtOut
12. 8.16 walter: f recursive %( %, %), fTst B,I,Y,Z / comp table deimp
if, else, proc etc. erlaub nl, * Kommentare für % und ^
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 truncat.
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 = 'v62e 1.11.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.pipeCnt = (out \== '') * 2
if m.wsh.pipeCnt == 2 then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
if isEdit then
call wshEditEnd wsh
do m.wsh.pipeCnt
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'wsh end: pipe.0='m.pipe.0
else if m.err_cleanup <> '\?' | m.tso_ddAll <> '' then
call err 'wsh end: still err cleanups'
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if sysVar(sysNode) = 'RZ0' then
return
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 = '*'
call wshIni
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 wshHookComp( ,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 ***************************************/
/* 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))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
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
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy 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 = 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 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
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
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
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 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 ************************************************/
/--- 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 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
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 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 ************************************/
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
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
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 sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
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"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- 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 */
call csmAppc 'csmASql', , , 4
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
**********************************************************************/
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
m.sql.cx.sqlClosed = 1
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
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
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:
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 ******************************************************/
/* 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
call iiIni
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? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy 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;" ,
"wStem = m''.BUF'';'" ,
"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
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* 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 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.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
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' 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 *******************************************************/
/* copy tstAll begin ************************************************/
tstAll: procedure expose m.
say 'tstAll' m.myWsh m.myVers
call tstBase
call tstComp
call tstDiv
if m.err_os = 'TSO' then do
call tstZos
call tstTut0
end
call tstTimeTot
return 0
endProcedure tstAll
/*--- with also the slow tests --------------------------------------*/
tstAlLong: procedure expose m.
call tstIni
m.tst_long = 1
return tstAll()
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 ##########################################
#noPds: -99 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 = 00000D693A400000 = 14745600000000 = 3600.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-11.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
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 , 'e'
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 , 'e'
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 , 'e'
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 tst t, "tstSqlCsm"
call sqlConnect m.tst_csmRzDb, 'c'
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 sqlConnect , 'r'
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 , 'e'
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 tst t, 'tstSqlFTab'
call sqlConnect , 'r'
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 tst t, 'tstSqlFTab2'
call sqlConnect , 'r'
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 sqlConnect , 'r'
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 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 , 'e'
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.
/*
$=/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/
### 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
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.S+
YSDUMMY1 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 RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
$=/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/
*/
call pipeIni
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 , 'r'
sys = 'local'
end
else if tx=2 then do
call tst t, "tstSqlCCsm"
sys = m.tst_csmRzDb 'csm'
call sqlConnect m.tst_csmRzDb, 'c'
end
else do
call tst t, "tstSqlCWsh"
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 , 'e'
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 , 'e'
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 , 'e'
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 , 'e'
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 sqlConnect , 's'
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 pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect , 's'
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 sqlConnect , 'r'
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 sqlConnect , 'r'
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 tst t, "tstSqlS1"
call sqlConnect , 'r'
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 sqlconClass_w
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 sqlconClass_w
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 sqlConnect , 's'
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 sqlConnect , 's'
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 tstMain
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 tstCompWithNew
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 = wshHookComp(tstWWWW, spec, src)
noSyn = m.err.count = oldErr
coErr = m.t.err
if noSyn then
say "compiled" r ":" objMet(r, 'oRun')
else
say "*** syntaxed"
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;
tstR: @ obj null
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
tstCompProc: procedure expose m.
/*
$=/tstCompProc1/
### start tst tstCompProc1 ########################################
compile =, 11 lines: $$ vor1
run without input
vor1
called p1 eins
vor2
tstR: @ obj null
vor3
. called p3 drei
vor4
. called p2 .
vor9 endof
$/tstCompProc1/ */
call pipeIni
call compIni
call tstComp1 '= tstCompProc1',
, "$$ vor1",
, "$@% p1 eins $$vor2 $@% p2 zwei $$vor3 $@% p3 drei",
, "$$ vor4 $proc p1 $$- 'called p1' arg(2)",
, "$proc p2", " ", "$** a", "$*(b$*) called p2 $-¢arg(2)$!",
, "$proc p3 ", "$** a", " $*(b$*) called p3 $-¢arg(2)$!",
, "$$ vor9 endof"
return
endProcedure tstCompProc
tstCompSyntax: procedure expose m.
call pipeIni
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 $ =
$/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 $. {
$/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 $- ¢
$/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
$/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 3 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'
/*
$=/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
$/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
$/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: $@
$/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: atEnd after 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: atEnd after line 3: .
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' '
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 3 lines: a
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: $**x
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc ' , '$**x'
/*
$=/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', '$$'
$=/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$!
$/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
tstCompWithNew: procedure expose m.
/*
$=/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 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 ': 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 tstCompWithNew
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 sqlConnect , 's'
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
$<>
$<#¢
db ts
DGDB9998 A976
DA540769 A977
$!
$@. csvColRdr()
$** $| 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 , 33 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 classIni
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call tstOStr
call tstOEins
call tstO2Text
call tstF
call tstFWords
call tstFtst
call tstFCat
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvLong
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
call tstDsn2
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstFUnit
call tstfUnit2
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 = asString
. .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 classIni
call tst t, 'tstO'
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
tstOStr: procedure expose m.
/*
$=/tstOStr/
### start tst tstOStr #############################################
. kindOfStri 1
. asString .
. asString - .
. o2String .
abc kindOfStri 1
abc asString abc
abc asString - abc
abc o2String abc
!defg kindOfStri 1
!defg asString defg
!defg asString - defg
!defg o2String defg
TST_STR kindOfStri 0
*** err: TST_STR is not a kind of string but has class TstStr
TST_STR asString 0
TST_STR asString - -
*** err: no method o2String in class TstStr
*** err: o2String did not return
TST_STR o2String 0
lllllll... kindOfStri 1
lllllll... asString llllllllll
lllllll... asString - llllllllll
lllllll... o2String llllllllll
$/tstOStr/
*/
call classIni
o = oMutate(tst_str, classNew('n? TstStr u'))
call mAdd mCut(tstStr, 0), '', 'abc', '!defg', o, left('',500,'l')
call tst t, 'tstOStr'
do ix=1 to m.tstStr.0
e = m.tstStr.ix
f = e
if length(e) > 10 then
f = left(e, 7)'...'
call tstOut t, f 'kindOfStri' oKindOfString(e)
call tstOut t, f 'asString ' strip(left(oAsString(e),10))
call tstOut t, f 'asString -' strip(left(oAsString(e,'-'),10))
call tstOut t, f 'o2String ' strip(left(o2String(e),10))
end
call tstEnd t
return
endProcedure tstOStr
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...!
o2 > tstO2T2=¢f2f=v_o2_f2f =value_o2!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = oMutate('tstO2T1', cl)
o1 = oMutate('tstO2T1', cl)
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'
c2 = classNew('n? TstO2Text2 u f f2f v, v')
o2 = oMutate('tstO2T2', c2)
call mPut o2'.f2f', 'v_o2_f2f'
call mPut o2 , 'value_o2'
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)
call tstOut t, 'o2 >' o2Text(o2 , 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
tstEnvLong: procedure expose m.
call pipeIni
/*
$=/tstEnvLong/
### start tst tstEnvLong ##########################################
before pipeWriteAll
after pipeWriteAll
file out 1010 = comp 1010
$/tstEnvLong/
*/
call tst t, "tstEnvLong"
o = tstFileName('envLong', 'r')
q = time() date()
b = jBuf()
do ix=1 to 100
m.b.buf.ix = ix q
end
m.b.buf.0 = 100
i = jOpen(cat(), '>')
c = 'tstEnvLongC'
m.c.0 = 0
do ix=1 to 10
call jWrite i, 'vor loop' ix
call mAdd c, 'vor loop' ix
call jWriteAll i, b
call maddSt c, b'.BUF'
end
call pipe '+Ff', file(o '::f'), jClose(i)
call tstOut t, 'before pipeWriteAll'
call pipeWriteAll
call tstOut t, 'after pipeWriteAll'
call pipe '-'
p = jOpen(file(o), '<')
do ix = 1 while jRead(p)
if m.c.ix <> m.p then
call tstOut t, ix '<>' m.c.ix '<>' m.p
end
call jClose p
call tstOut t, 'file out' (ix-1) '= comp' m.c.0
call tstEnd t
return
endProcedure tstEndLong
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
$/tstDsn/
$=/tstDsnL/
### start tst tstDsnL #############################################
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 1/5, seqFuenf 2/5, seqFue+
nf 3/5, seqFuenf 4/5, seqFuenf 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 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 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
$/tstDsnL/
*/
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 tstEnd t
if sx & \ m.tst_long then
iterate
call tst t, 'tstDsnL'
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 suf, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn suf, 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
tstDsn2: procedure expose m.
/*
$=/tstDsnEq/
### start tst tstDsnEq ############################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnEq/
$=/tstDsnLng/
### start tst tstDsnLng ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnLng/
$=/tstDsnSht/
### start tst tstDsnSht ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/
p2s= TSTDSNS 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(EINS) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
$/tstDsnSht/
*/
call tstIni
tCnt = 0
cRZ = (m.tst_csmRZ \== '') * 3
if m.tst_long then
cSel = ''
else do /* one with iebCopy one with copyW */
cSel = random(0, 10*(cRz+1) - 1)
cSel = cSel + cSel % 5 + 2 random(0, 2*(cRz+1) - 1) * 6 + 1
say 'tstDsn2 selects' cSel
end
do sx=0 to cRz
sFr = copies(m.tst_csmRz'/', sx >= 2)
sTo = copies(m.tst_csmRz'/', sx // 2)
do fx=1 to 2
ff = substr('FV', fx, 1)
fWr = 1
do ty=1 to 2
tx = 1 + (fx <> ty)
tA = word('::F50 ::V54', tx)
tf = substr(tA, 3, 1)
tA = copies(tA, ff <> tf)
do lx=1 to 3 /* 1 + 2 * (ff = tf) */
tCnt = tCnt + 1
if wordPos(tCnt, cSel) < 1 & cSel <> '' then
iterate
if lx = 1 then do
tq = 'Eq'
end
else if lx = 2 then do
tq = 'Lng'
tA = '::'tf'60'
end
else do
tq = 'Sht'
tA = '::'tf || if(tf=='F', 10, 14)
end
if fWr then do
fWr = 0
fS = tstFileName(sFr'fr'ff'.tstDsnS', 'r')
fP = tstFileName(sFr'fr'ff'.tstDsnP', 'r')
call tstDsnWr fS '::'ff'50', 1
call tstDsnWr fP'(eins) ::'ff'50', 2
end
call tst t, 'tstDsn'tq
say '>>>>> csm/sys from' sFr ff 'to' sTo tf tq tA ,
'<<<<<' tCnt 'ff=tf' (ff=tf)
tS = tstFileName(sTo || tq || tf'.tstDsnS', 'r')
tP = tstFileName(sTo || tq || tf'.tstDsnP', 'r')
call dsnCopy fS, tS tA
call tstOut t, 'seq=' tstDsnR1(tS)
call dsnCopy '-' fP'(eins)', tS tA
call tstOut t, 'p2s=' tstDsnR1(tS)
call dsnCopy fP'(eins)', tP'(zwei)' tA
call tstDsnRL t, tP, 'par='
call dsnCopy fS, tP'(seq)' tA
call dsnCopy fP, tP tA, 'eins>drei'
call dsnCopy fP, tP tA
call tstDsnRL t, tP, 's>*='
call tstEnd t
end
end
end
end
return
endProcedure tstDsn2
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: csm rc=8 .
. e 1: stmt=csmExec allocate SYSTEM(?QZ) DDNAME(MBRLISDD) DATASE+
T('A540769.WK.RXXYY') DISP(SHR) timeout(30) .
. e 2: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 3: CSMSI77E SYSTEM=?QZ,TIMEOUT=30 .
%%%
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;
f(a%(b%3Cc%)d, eins, zwei ) =abinscd;
f(a%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbinef;
f(a@2%(b%3Cc%)d, eins, zwei ) =abei cd;
f(a@2%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbeief;
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'
call tstF1 'a%(b%3Cc%)d'
call tstF1 'a%(b%3Cc%,d%-3Ce%)f'
call tstF1 'a@2%(b%3Cc%)d'
call tstF1 'a@2%(b%3Cc%,d%-3Ce%)f'
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 .
, #0-- --
#a%9c#l<<#r>> <<>>
*#a%-7c .
??empty?? eins
1space eins
, #0-- eins
#a%9c#l<<#r>> << eins>>
*#a%-7c eins .
??empty?? einszwei
1space eins zwei
, #0-- eins, zwei
#a%9c#l<<#r>> << eins zwei>>
*#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, #0-- eins, zwei, drei
#a%9c#l<<#r>> << 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, ', #0-- ' fWords(', #0--' ,subword(ws,1,l))
call tstOut t, '#a%9c#l<<#r>>',
fWords('#a%9c#l<<#r>>' ,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 SZ => 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 SY => GB29X3LV|
1956-01-29-23.34.56.987654 SA => C9233456|
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 sZ => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sY => OM23Q5SI|
2014-12-23-16.57.38 sA => C3165738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
$/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 DZ => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 DY => UG18A0AA|
23450618 DA => B8000000|
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 dZ => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dY => MH24A0AA|
120724 dA => C4000000|
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 EZ => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 EY => UM09A0AA|
09.12.1345 EA => A9000000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.24 eS => 2024-05-31-00.00.00.000000|
31.05.24 es => 2024-05-31-00.00.00|
31.05.24 e => 2024-05-31-00.00.00|
31.05.24 eD => 20240531|
31.05.24 ed => 240531|
31.05.24 eE => 31.05.2024|
31.05.24 ee => 31.05.24|
31.05.24 et => 00.00.00|
31.05.24 eT => 00:00:00.000000|
31.05.24 eZ => OF31|
31.05.24 eM => F3100000|
31.05.24 eH => A00000|
31.05.24 eY => YF31A0AA|
31.05.24 eA => D1000000|
31.05.24 ej => 24152|
31.05.24 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 tZ => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tY => ??01M3LV|
12.34.56 tA => A1123456|
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 TZ => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 TY => ??01X4MG|
23.45.06.784019 TA => A1234506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstYold/
### start tst tstFTstY ############################################
PE25 YS => 2015-04-25-00.00.00.000000|
PE25 Ys => 2015-04-25-00.00.00|
PE25 Y => 2015-04-25-00.00.00|
PE25 YD => 20150425|
PE25 Yd => 150425|
PE25 YE => 25.04.2015|
PE25 Ye => 25.04.15|
PE25 Yt => 00.00.00|
PE25 YT => 00:00:00.000000|
PE25 YZ => ?E25|
PE25 YM => E2500000|
PE25 YH => A00000|
PE25 YY => PE25A0AA|
PE25 YA => C5000000|
PE25 Yj => 15115|
PE25 YJ => 735712|
$/tstFTstYold/
$=/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 MZ => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 MY => ?I23R4XP|
I2317495 MA => C3174950|
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 HZ => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 HY => ??01M3LV|
B23456 HA => A1123456|
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 nZ => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nY => GE23R5UJ|
19560423 17:58:29 nA => C3175829|
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 NZ => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 NY => KM30K2DR|
32101230 10:21:32.456789 NA => D0102132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
$=/tstFTstY/
### start tst tstFTstY ############################################
RF06R2UT YS => 2017-05-06-17.28.39.000000|
RF06R2UT Ys => 2017-05-06-17.28.39|
RF06R2UT Y => 2017-05-06-17.28.39|
RF06R2UT YD => 20170506|
RF06R2UT Yd => 170506|
RF06R2UT YE => 06.05.2017|
RF06R2UT Ye => 06.05.17|
RF06R2UT Yt => 17.28.39|
RF06R2UT YT => 17:28:39.000000|
RF06R2UT YZ => ?F06|
RF06R2UT YM => F0617283|
RF06R2UT YH => B72839|
RF06R2UT YY => RF06R2UT|
RF06R2UT YA => A6172839|
RF06R2UT Yj => 17126|
RF06R2UT YJ => 736454|
$/tstFTstY/
*/
say "current time '%t '" f('%t ') "'%t D'" f('%t D')
say " '%t S'" f('%t S') "'%t t'" f('%t t') "'%t T'" f('%t T')
allOut = 'Ss DdEetTZMHYAjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.24' ,
't12.34.56' ,
'T23.45.06.784019' ,
/* 'YPE25' ,
*/ 'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789',
'YRF06R2UT'
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
tstFUnit2: procedure expose m.
/* b
$=/tstFUnit2/
### start tst tstFUnit2 ###########################################
. 12 = 12 12
. 23k = 23000 23552
34 K = 34000 34816
45 M = 45000000 47185920
567G = 567000000000 608811614208
. 678 = 678
$/tstFUnit2/
*/
call tst t, 'tstFUnit2'
call tstOut t, ' 12 =' fUnit2I('d',' 12 ') fUnit2I('b',' 12 ')
call tstOut t, ' 23k =' fUnit2I('d',' 23k') fUnit2I('b',' 23k')
call tstOut t, '34 K =' fUnit2I('d','34 K ') fUnit2I('b','34 K ')
call tstOut t, '45 M =' fUnit2I('d','45 M') fUnit2I('b','45 M')
call tstOut t, '567G =' fUnit2I('d','567G') fUnit2I('b','567G')
call tstOut t, ' 678 =' fUnit2I('t',' 678 ')
/* t umbauen, funktioniert nicht mit jetztigen Metadaten ||||
call tstOut t, ' 78 s ='fUnit2I('t', ' 78 s ')
call tstOut t, '567G' fUnit2I('t', ' 123 ') */
call tstEnd t
return
endProcedure tstFU
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
tstFUnit: procedure
/*
$=/tstFUnit/
### start tst tstFUnit ############################################
. 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 ==> 0a =-> -0a =+> +0a =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.000a =-> -0.000a =+> +0.000a =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -++++++ =+> +++++++ =b> 16.083E
. 20.987E20 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
$/tstFUnit/
$=/tstFUnitT/
### start tst tstFUnitT ###########################################
. .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 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstFUnitT/ */
call jIni
call tst t, "tstFUnit"
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) ,
'==>' fUnit('d' , word(lst, wx)),
'=->' fUnit('d' , '-'word(lst, wx)),
'=+>' fUnit('d¢+', word(lst, wx)),
'=b>' fUnit('b' , word(lst, wx))
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d7.3' , word(lst, wx)),
'=->' fUnit('d7.3' , '-'word(lst, wx)),
'=+>' fUnit('d7.3¢+', word(lst, wx)),
'=b>' fUnit('b7.3' , word(lst, wx))
end
call tstEnd t
call tst t, "tstFUnitT"
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) ,
'==>' fUnit('t' , word(lst, wx)),
'++>' fUnit('t¢ ', word(lst, wx)),
'-+>' fUnit('t' , '-'word(lst, wx)),
'-->' fUnit('t¢ ', '-'word(lst, wx))
end
call tstEnd t
return
endProcedure tstFUnit
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
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
$/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
$/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
/**** 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 fUnit('d', 3e7)
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
if m.tstTime_ini \== 1 then do
m.tstTime_ini = 1
m.tstTimeNm = ''
aE = right(time('L'), 20, 0)
m.tstTimeLaEla = substr(aE, 12) ,
+ 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
m.tstTimeLaCpu = sysvar('syscpu')
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
nm = strip(m.m.name)
aE = right(time('L'), 20, 0)
aE = substr(aE, 12) + 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
aC = sysvar('syscpu')
if aE < m.tstTimeLaEla | aC < m.tstTimeLaCpu then
call err 'backward time/cpu'
if m.tstTime.nm \== 1 then do
m.tstTime.nm = 1
m.tstTimeNm = m.tstTimeNm nm
m.tstTime.nm.count = 1
m.tstTime.nm.ela = aE - m.tstTimeLaEla
m.tstTime.nm.cpu = aC - m.tstTimeLaCpu
end
else do
m.tstTime.nm.count = m.tstTime.nm.count + 1
m.tstTime.nm.ela = m.tstTime.nm.ela + aE - m.tstTimeLaEla
m.tstTime.nm.cpu = m.tstTime.nm.cpu + aC - m.tstTimeLaCpu
end
/* say left('%%%time' nm, 20) ,
f('%7.3i %9.3i', aC - m.tstTimeLaCpu , aE - m.tstTimeLaEla) ,
f('cum %6i %7.3i %9.3i', m.tstTime.nm.count, m.tstTime.nm.cpu,
, m.tstTime.nm.ela) */
m.tstTimeLaEla = aE
m.tstTimeLaCpu = aC
return
endProcedure tstEnd
tstTimeTot: procedure expose m.
tCnt = 0
tCpu = 0
tEla = 0
say 'tstTimeTotal'
do tx=1 to words(m.tstTimeNm)
nm = word(m.tstTimeNm, tx)
say left(nm, 12) f('%6i %7.3i %9.3i', m.tstTime.nm.count,
, m.tstTime.nm.cpu, m.tstTime.nm.ela)
tCnt = tCnt + m.tstTime.nm.count
tCpu = tCpu + m.tstTime.nm.cpu
tEla = tEla + m.tstTime.nm.ela
end
say left('total', 12) ,
f('%6i %7.3i %9.3i', tCnt, tCpu, tEla)
return
endProcedre tstTimeTot
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'
m.tst_long = 0
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 & c \== '%%%' 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.SQL(ABUBDDL) cre=2013-11-20 mod=2016-11-23-15.29.47 A540769 ---
set current sqlid = 'S100447';
drop view oa1p.vQZ045AbUbLast ;
drop view oa1p.vQZ046AbUbCal ;
create view oa1p.vQZ045AbUbLast as
with r as
(
select rule ab
, type, subType
, char(va1, 3) rz
, char(va2, 4) dbSy
, va3, va4
from oa1p.tQZ046AbUbRule
where type in ('ab', 'abub', 'conn')
)
, s as
(
select r.*
, (select max(e.tst)
from oa1p.tQZ045AbUbEvent e
where r.ab = e.ab and r.rz = e.rz and r.dbSy = e.dbSy
) evTst
from r
)
, l as
(
select s.*, e.event, e.orTst, e.link, e.cont
from s
left join oa1p.tQZ045AbUbEvent e
on s.ab = e.ab and s.rz = e.rz and s.dbSy = e.dbSy
and s.evTst = e.tst
)
select f.*, c.evTst conTst, c.event conEv, c.subType conPri
, ( select evTst from s where s.ab = 'abub') abubTst
from l f
left join l c
on c.ab = 'connect' and c.type = 'conn'
and c.rz = f.rz
;
create view oa1p.vQZ046AbUbCal as
with d (dt, x) as
(
select current date, 0 from sysibm.sysDummy1
union all select dt - 1 days, x+1 from d where x < 8
)
, t as
(
select cast( timestamp(dt, strip(va2)||':00') as timestamp(0)) start
, r.*
from d join oa1p.tQZ046AbUbRule r
on r.type = 'cal' and r.subType not like 'trunc%'
)
, s as
(
select *
from t where 0 <
case when subType = 'wtZe'
then locate(dayOfWeek_iso(start), va1)
else raise_error(77701, 'cal bad subType ' || subType)
end
union all select
case when subType = 'truncHH'
then trunc_timestamp(current timestamp, 'hh')
when subType = 'truncDD'
then trunc_timestamp(current timestamp, 'dd')
else raise_error(77702, 'cal bad subType ' || subType)
end start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType like 'trunc%'
union all select
case when subType = 'truncHH'
then trunc_timestamp(current timestamp, 'hh') - 1 hour
when subType = 'truncDD'
then trunc_timestamp(current timestamp, 'dd') - 1 day
else raise_error(77702, 'cal bad subType ' || subType)
end start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType like 'trunc%'
)
, o1 as
(
select s.*
, case when strip(va3) like 'e%' then 'e' else 's' end tiOuTy
from s
)
, o2 as
(
select o1.*
, midnight_seconds(time(
case when tiOuTy = 's' then strip(va3)
else strip(substr(strip(va3), 2)) end ||':00')) tiOuSecs
from o1
)
select rule cal
, cast(start as timestamp(0)) start
, tiOuTy, tiOuSecs
, va4 calVa4
from o2
;
create view oa1p.vQZ046AbUbCur as
with c as
(
select c.*
, row_number() over (partition by cal order by start desc) rn
from oa1p.vQZ046AbUbCal c
where start <= current timestamp
)
select a.cal, a.start, a.tiOuTy, a.tiOuSecs, a.calVa4
, b.start prStart
from c a left join c b on a.cal = b.cal and b.rn = 2
where a.rn = 1
;
create view oa1p.vQZ045AbubState as
with r as
(
select cast( case when tiOuTy = 'e' then evTst else start end
+ tiOuSecs seconds as timestamp(0)) until
, r.*, c.*
from oa1p.vQZ045AbUbLast r
left join oa1p.vQZ046AbUbCur c
on r.type = 'ab' and r.subType = c.cal
)
, s1 as
(
select -- s1 = timout or alarmTimeout (new)
case when event is null or evTst is null then ' t'
when cal is null then ''
when evTst >= start and event not like '>%' then ''
when until < abubTst then ' t'
when until < current timestamp then 'at'
when evTst >= start or tiOuTy = 'e' then ''
when evTst < prStart or event like '>%' then ' t'
else ''
end s1
, r.*
from r
)
, s2 as
(
select
case
when type = 'conn' then -- connection: alarm?
case when conTst is null then ' timeout'
when conTst >= abubTst then 'a' || event
else ' ' || event
end
when s1 = '' then -- event: in progress or alarm?
case when event like '>%' then ' >'
when event = 'ok' or evTst <= abubTst then ' '||event
else 'a'||event
end
else -- timeout: is connection the reason?
case when conEv is null or conEv <> 'ok' then 'cconTimeout'
when conTst + tiOuSecs seconds > current timestamp
then 'cconRestart'
else left(s1, 1) || 'timeout'
end
end s2
, s1.*
from s1
)
, o as
(
select rz, dbSy, ab
, substr(s2, 1, 1) alarm
, substr(s2, 2, 10) state
-- , s1
, event, evTst, orTst, link, cont
, start, until, cal, tiOuTy, tiOuSecs, calVa4, prStart
, conEv, conTst
, abubTst
, type, subType, va3, va4
from s2
order by conPri, dbSy, ab
)
select * from o
;
rollback
}¢--- A540769.WK.SQL(ABUBDDLT) cre=2016-11-23 mod=2016-11-23-15.28.30 A540769 ---
set current sqlid = 'S100447';
xrop tablespace qz01a1p.a045a ;
xrop tablespace qz01a1p.a046a ;
commit;
CREATE TABLESPACE a045a
IN qz01a1p
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
TRACKMOD YES
SEGSIZE 64
BUFFERPOOL BP2
LOCKSIZE ANY
LOCKMAX SYSTEM
CLOSE YES
COMPRESS YES
CCSID UNICODE
DEFINE YES
MAXROWS 255
;
CREATE TABLESPACE a046a
IN qz01a1p
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
TRACKMOD YES
SEGSIZE 64
BUFFERPOOL BP2
LOCKSIZE ANY
LOCKMAX SYSTEM
CLOSE YES
COMPRESS YES
CCSID UNICODE
DEFINE YES
MAXROWS 255
;
CREATE TABLE oa1p.tQZ045AbUbEvent
( ab CHAR(8) NOT NULL
, rz CHAR(3) NOT NULL
, dbSy char(4) NOT NULL
, tst timestamp(0) not null
, event char(4) NOT NULL
, orTst timestamp(0) not null default '0001-01-01-00.00.00'
, link char(60) NOT NULL default
, cont varchar(500) not null default
)
in qz01a1p.a045a
;
CREATE UNIQUE INDEX oa1p.iQZ045A1
ON oa1p.tQZ045AbUbEvent
(ab, rz, dbSy, tst)
include (event)
USING STOGROUP GSMS
ERASE NO
GBPCACHE CHANGED
not CLUSTER
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
;
CREATE TABLE oa1p.tQZ046AbUbRule
( rule char(8) not null
, type char(8) not null
, subType char(8) not null
, va1 char(16) not null
, va2 char(16) not null
, va3 char(60) not null with default
, va4 char(200) not null with default
)
in qz01a1p.a046a
;
CREATE INDEX oa1p.iQZ046A1
ON oa1p.tQZ046AbUbRule
(rule, type, subType, va1, va2)
USING STOGROUP GSMS
ERASE NO
GBPCACHE CHANGED
not CLUSTER
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
;
}¢--- A540769.WK.SQL(ABUBDDLV) cre=2015-06-04 mod=2016-11-23-15.35.56 A540769 ---
-- select * from oa1p.vQZ045AbUbStat3 ; x where rz = 'RZZ' ;x;
set current sqlid = 'S100447';
drop view oa1p.vQZ045AbUbLast ;
drop view oa1p.vQZ046AbUbCal ;
drop view oa1p.vQZ046AbubCa3 ;
create view oa1p.vQZ046AbubCal as
with d (dt, x) as
(
select current date + 8 days, 0 from sysibm.sysDummy1
union all select dt - 1 days, x+1 from d where x < 25
)
, t as
(
select cast( timestamp(dt, strip(va2)||':00') as timestamp(0)) start
, r.*
from d join oa1p.tQZ046AbUbRule r
on r.type = 'cal' and r.subType not like 'trunc%'
)
, c1 as
(
select *
from t
where 0 < case when subType = 'wtZe'
then locate(dayOfWeek_iso(start), va1)
else raise_error(77701, 'cal bad subType ' || subType)
end
union all select trunc_timestamp(current timestamp, 'hh') start
, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncHH'
union all select trunc_timestamp(current timestamp, 'hh')
+ 1 hour start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncHH'
union all select trunc_timestamp(current timestamp, 'hh')
- 1 hour start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncHH'
union all select trunc_timestamp(current timestamp, 'dd') start
, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncDD'
union all select trunc_timestamp(current timestamp, 'dd')
+ 1 day start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncDD'
union all select trunc_timestamp(current timestamp, 'dd')
- 1 day start, r.*
from oa1p.tQZ046AbUbRule r
where r.type = 'cal' and r.subType = 'truncDD'
)
, c2 as
(
select c1.*
, case when strip(va3) like 'e%' then 'e' else 's' end tiOuTy
from c1
)
, c3 as
(
select c2.*
, midnight_seconds(time(
case when tiOuTy = 's' then strip(va3)
else strip(substr(strip(va3), 2)) end ||':00')) tiOuSecs
, case when cast(start as timestamp(0)) <= current timestamp
then 1 else 0 end past
from c2
)
, c as
(
select rule cal
, cast(start as timestamp(0)) start
, smallInt( (row_number() over(partition by rule, past
order by start desc) -1 ) * past
- (row_number() over(partition by rule, past
order by start asc)) * (1 - past)) seq
, tiOuTy, tiOuSecs
, va4 calVa4
from c3
)
select *
from c
where seq between -1 and 1
;
create view oa1p.vQZ045AbUbState as
with a as
(
select rule ab
, type, subType
, char(va1, 3) rz
, char(va2, 4) dbSy
, va3, va4
from oa1p.tQZ046AbUbRule
where type in ('ab', 'abub', 'conn')
)
, c1 as
(
select rz, max(tst) tst
from oa1p.tQZ045AbUbEvent e
where ab = 'connect'
group by rz
)
, con as
(
select a.rz, e.tst conTst, e.event conEv, a.subType conPri
, ( select value(max(e.tst), current timestamp)
from oa1p.tQZ045AbUbEvent e
where ab = 'abub'
) abubTst
from c1
join a
on a.ab = 'connect' and a.type = 'conn' and a.rz = c1.rz
join oa1p.tQZ045AbUbEvent e
on e.ab = 'connect' and e.rz = c1.rz and e.tst = c1.tst
)
, b as
( -- join current next and previous calender
select ab, a.type, subType, rz, dbSy
, nx.start nxStart
, cu.start cuStart
, case when type = 'conn' then 'c'
when cu.tiOuTy is null then 'n'
else cu.tiOuTy end ct
, cu.tiouTy cuTiOuTy
, cu.tiouSecs cuTiOuSecs
, cu.calVa4
, pr.start prStart
, pr.tiouTy prTiOuTy
, pr.tiouSecs prTiOuSecs
, pr.start + pr.tiouSecs seconds prUntil
, va3, va4
from a
left join oa1p.vQZ046AbubCal nx
on a.subType = nx.cal and nx.seq = -1
left join oa1p.vQZ046AbubCal cu
on a.subType = cu.cal and cu.seq = 0
left join oa1p.vQZ046AbubCal pr
on a.subType = pr.cal and pr.seq = 1
)
, tC as
( -- find timestamp of current Event
select b.*
, ( select max(e.tst)
from oa1p.tQZ045AbUbEvent e
where b.ab = e.ab and b.rz = e.rz and b.dbSy = e.dbSy
) cuTst
from b
)
, tP as
( -- find timestamp of previous Event
select tC.*
, ( select max(e.tst)
from oa1p.tQZ045AbUbEvent e
where tC.ab = e.ab and tC.rz = e.rz and tC.dbSy = e.dbSy
and e.tst < value(min(tC.cuStart, tC.cuTst)
, tC.cuTst)
and e.event <> '' and e.event not like '>%'
) prTst
, ( select max(e.tst)
from oa1p.tQZ045AbUbEvent e
where tC.ab = 'tecSv'
and tC.ab=e.ab and tC.rz = e.rz and tC.dbSy = e.dbSy
and strip(e.link) like 'DSN.ABUB.TECSV.%.CONSUM(%)'
) csTst
from tC
)
, e as -- join events
(
select tP.*
, cu.event cuEvent, cu.link cuLink
, pr.event prEvent, pr.link prLink
, cs.event csEvent, cs.link csLink
, conTst, conEv, conPri, abubTst
, cu.cont, cu.orTst
from tP
left join oa1p.tQZ045AbUbEvent cu
on tP.ab = cu.ab and tP.rz = cu.rz and tP.dbSy = cu.dbSy
and tP.cuTst = cu.tst
left join oa1p.tQZ045AbUbEvent pr
on tP.ab = pr.ab and tP.rz = pr.rz and tP.dbSy = pr.dbSy
and tP.prTst = pr.tst
left join oa1p.tQZ045AbUbEvent cs
on tP.ab = cs.ab and tP.rz = cs.rz and tP.dbSy = cs.dbSy
and tP.csTst = cs.tst
left join con on tP.rz = con.rz
)
, e2 as
( -- compute last finished event
select
case when cuEvent not like '>%' then cuEvent
when prEvent not like '>%' then prEvent
end fiEvent
, case when cuEvent not like '>%' then cuTst
when prEvent not like '>%' then prTst
end fiTst
, e.*
from e
)
, f as -- compute toTst: timeout timestamp
( -- compute timeout timestamp toTst
select case
when fiEvent is null then '0001-01-01-00.00.00'
when ct = 's' and fiTst >= cuStart then null
when ct = 's' and current timestamp
>= cuStart + cuTiOuSecs seconds
then cuStart + cuTiOuSecs seconds
when ct = 's' and fiTst >= prStart then null
when ct = 's' then prStart + prTiOuSecs seconds
when ct = 'e' and fiTst + cuTiOuSecs seconds
<= current timestamp then fiTst + cuTiOuSecs seconds
end toTst
, e2.*
from e2
)
/* ??????????????????????????????????
when ct = 's' then case
when cuEvent not like '>%' and cuTst >= cuStart then null
when cuStart + cuTiOuSecs seconds <= current timestamp
then cuStart + cuTiOuSecs seconds
when cuEvent not like '>%' and cuTst >= prStart then null
when prEvent not like '>%' and prTst >= prStart then null
else prStart + prTiOuSecs seconds
end
when ct = 'e' then case
when cuEvent not like '>%'
and cuTst + cuTiOuSecs seconds >= current timestamp
then null
when prEvent not like '>%'
and prTst + prTiOuSecs seconds >= current timestamp
then null
when cuTst + cuTiOuSecs seconds >= current timestamp
when cuStart + cuTiOuSecs seconds <= current timestamp
then cuStart + cuTiOuSecs seconds
when cuEvent not like '>%' and cuTst >= prStart then null
when prEvent not like '>%' and prTst >= prStart then null
else prStart + prTiOuSecs seconds
when cT = 's' and (cuEvent is null or cuEvent like '>%')
then cuStart+cuTiOuSecs seconds
when cT = 'e' and not (cuEvent is null or cuEvent like '>%')
then cuTst+cuTiOuSecs seconds
when cT = 'e'
then value(prTst + cuTiOuSecs seconds
, '0001-01-01-00.00.00')
end toTst
, e.*
from e
) ?????????????????????? */
, g as -- compute timeout: timeout text
( -- compute timeout timestamp toTst
select
case
when toTst is not null and (conEv is null
or conEv <> 'ok') then 'connTimeout'
when toTst is not null and conTst + cuTiOuSecs seconds
> current timestamp then 'connRestart'
when toTst is not null then 'timeout'
when cT = 's' and fiTst > cuStart + cuTiOuSecs seconds
then 'late'
when cT = 's' and fiTst < cuStart
and fiTst > prStart + prTiOuSecs seconds
then 'late'
when cT = 'e' and cuEvent not like '>%'
and prEvent not like '>%'
and cuTst > prTst + prTiOuSecs seconds
then 'late'
else ''
end timeout
, f.*
from f
)
, h as
( -- compute alarm and status
select substr(case
when fiEvent <> 'ok' then fiEvent
when timeout <> '' then timeout
when ab = 'tecSv' and rz = 'RZ2'
and dbSy in ('DBOF', 'DVBP') then 'prod'
else 'ok'
end, 1, 8) status
, case
when fiTst > abubTst then 'new'
when toTst > abubTst then 'new'
when toTst is null and nxStart > cuStart + 3 days
and cuTst < current timestamp - 1 day
then 'old' else ''
end alarm
, g.*
from g
order by conPri, rz, dbSy, ab
)
select rz, dbSy, ab
, alarm, status, timeout, cuEvent, cuTst, cuLink
, csEvent, csTst, csLink
, prEvent, prTst, prLink
, type, va3, va4
, cont, orTst, calVa4
, fiEvent, fiTst
, conTst, conEv, conPri, abubTst
, ct, nxStart
, cuStart, cuTiOuSecs, cuTiOuTy
, prStart, prTiOuSecs, prTiOuTy
from h
;
select * from oa1p.vQZ045AbUbState
;
rollback
}¢--- A540769.WK.SQL(ALIASMK) cre=2010-06-15 mod=2016-11-03-09.27.27 A540769 ---
$*(--- wsh script um Alias abzugleichen -------------------------------
1. $=fun=list: eine Liste der Alias erstellen, ins dsn $aliasDsn
==> auf dem quellSystem, connect auf die richtige ssid|
2. $=fun=comp: Alias vergleichen: die fehlenden
oder unterschiedlichen aliase rausschreiben
==> auf dem zielSystem, connect auf die richtige ssid|
3. $=fun=crea: create fehlende Alias (sonst wie comp)
-------------------------------------------------------------------- $*)
call sqlConnect dbtf
$=fun = comp
$=aliasDsn=A540769.WK.TEXW(ALIAS)
eq = 0
nn = 0
if $fun == 'list' then $@¢
$>$aliasDsn
call sqlPreOpen 1, "select strip(creator) || '.' || strip(name),",
"strip(location), createdTs, ",
"strip(tbCreator) || '.' || strip(tbName)",
"from sysibm.sysTables" ,
"where type = 'A'",
"order by 1, 2"
do while sqlFetchInto(1, ":tb, :loc, :cr, :to")
$$- 'tb' tb 'loc' loc 'to' to 'cr' cr
nn = nn + 1
end
say nn 'alias gefunden'
call sqlClose 1
$! else $@¢
call sqlExec "set current sqlId = 'S100447'"
$@proc prep $@¢
call sqlPrepare 1, "select strip(creator) || '.' || strip(name),",
"strip(location), createdTs, type, ",
"strip(tbCreator) || '.' || strip(tbName)",
"from sysibm.sysTables" ,
"where creator = ? and name = ?"
$!
$@prep()
$;
$<$aliasDsn
$@for line $@¢
parse value $line with 'tb' cr '.' tb 'loc' loc 'to' to 'cr' tst .
if sqlOpAllCl(1, st, ":fTb, :fLo, :fTst, :fTy, :fTo",
, strip(cr), strip(tb)) = 1 then do
if strip(loc) = fLo & strip(to) = fTo & fTy == 'A' then do
eq = eq+1 /* say 'equal' strip(fTb) '=' */
end
else do
m = 'notEq' strip(fTb)':' strip(loc)'.'strip(to) ,
'<>' fTy fLo'.'fTo
say m
$$- m
end
end
else if m.st.0 > 0 then do
say tb 'with' m.st.0 'rows'
end
else do
$$- 'missing' strip(cr)'.'strip(tb) 'loc' strip(loc) $*+
'to' strip(to) tst
if loc = '' & $fun == 'crea' then do
call sqlExec 'create alias' strip(cr)'.'strip(tb) ,
'for' strip(to)
nn = nn + 1
if nn // 100 = 1 then do
say 'created' nn strip(cr)'.'strip(tb)
call sqlCommit
$@prep()
end
end
end
$!
call sqlCommit
say 'total equal' eq
$!
call sqlDisconnect
$#out 20100615 16:50:30
$#out 20100615 16:48:52
$#out 20100615 16:47:50
$#out 20100615 16:16:57
notEq OA1P.TTP011A1RZ4: CHSKA000DBOL.OA1P.TTP011A1 <> A .OA1P.TTP011A1
notEq OA1P.TTP012A1RZ4: CHSKA000DBOL.OA1P.TTP012A1 <> A .OA1P.TTP012A1
notEq OA1P17.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P17.TAV415A1: .OA1P03.TAV415A1 <> T ..
notEq OA1P18.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P18.TAV415A1: .OA1P03.TAV415A1 <> T ..
notEq OA1P19.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P19.TAV415A1: .OA1P03.TAV415A1 <> T ..
notEq OA1P20.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P20.TAV415A1: .OA1P03.TAV415A1 <> T ..
notEq OA1P21.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P21.TAV415A1: .OA1P03.TAV415A1 <> T ..
notEq OA1P22.TAV413A1: .OA1P03.TAV413A1 <> T ..
notEq OA1P22.TAV415A1: .OA1P03.TAV415A1 <> T ..
$#out 20100615 16:16:42
}¢--- A540769.WK.SQL(CATCOLS) cre=2010-07-28 mod=2016-11-24-13.46.16 A540769 ---
with r (l, n) AS
(
select varchar('', 1000), 0 from sysibm.sysDummyU
union all select l || case when name = 'USERID'
then '' else ', ' || strip(name) end
, n+1
from r, sysibm.sysColumns where tbCreator = 'PTI'
and tbName = 'PTRCQ_SAVED_RPTS' and colNo = n + 1
and n < 999999
)
select max(l) from r
}¢--- A540769.WK.SQL(CATPKCO) cre=2016-10-24 mod=2016-10-24-13.44.16 A540769 ---
with u as
(
select 'pk' || copyid t, p.* from sysibm.sysPackage p
union all select 'co' || copyid t, c.* from sysibm.sysPackCopy c
)
select *
from u
where location = '' and collid = 'DSNREXX_500'
;
select *
from sysibm.syspksystem
}¢--- A540769.WK.SQL(CATPKGCN) cre=2012-09-25 mod=2016-10-24-11.07.46 A540769 ---
set current application compatibility 'V11R1';
with p2 as
(
select p.*
, dense_rank() over(partition by location, collid, name
order by lastUsed desc) usSeq
, row_number() over(partition by location, collid, name
order by pcTimestamp desc) pcSeq
from sysibm.syspackage p
)
, p as
(
select case
when sysentries <> 0 then '0sysEnt<>0'
when timestamp > current timestamp - 1 month then '0creM'
when lastUsed > current date - 1 month then '0lastM'
when valid = 'N' and lastUsed < current date - 1 year
then '1validN'
when pcSeq <= 2 then '0pc2'
when lastUsed >= current date - 1 year and usSeq <= 2
then '0us2'
else '1else' end delRea
, p2.*
from p2
)
select left(delRea, 1) del, substr(delRea, 2) reason, count(*) pkgVers
, sum(case when pcSeq = 1 then 1 else 0 end) pkg
, sum(case when pcSeq <= 2 then 1 else 0 end) pkg2V
, sum(case when pcSeq <= 3 then 1 else 0 end) pkg3V
, sum(case when usSeq <= 1 then 1 else 0 end) use1
, sum(case when usSeq <= 2 then 1 else 0 end) use2
, sum(case when usSeq <= 3 then 1 else 0 end) use3
, sum(case when lastUsed > current date - 1 year
then 1 else 0 end) usedLastY
from p
group by rollup(left(delRea, 1), substr(delRea, 2))
;x;
, p as
(
select valid, operative, count(*) pkgVers
, sum(case when pcSeq = 1 then 1 else 0 end) pkg
, sum(case when pcSeq <= 2 then 1 else 0 end) pkg2V
, sum(case when pcSeq <= 3 then 1 else 0 end) pkg3V
, sum(case when usSeq <= 1 then 1 else 0 end) use1
, sum(case when usSeq <= 2 then 1 else 0 end) use2
, sum(case when usSeq <= 3 then 1 else 0 end) use3
, sum(case when lastUsed > current date - 1 year
then 1 else 0 end) usedLastY
, sum(case when pcSeq <= 3 then 1
when lastUsed >= current date - 1 year
then 1 else 0 end) pkg3VorLaY
, sum(case when pcSeq <= 2 then 1
when lastUsed < current date - 1 year then 0
when usSeq <= 2 then 1
else 0 end) pkg2V2ULaY
, sum(case when sysEntries = 0 then 0 else 1 end) sysEntNot0
from p
group by rollup(valid, operative)
;x;
select *
from sysibm.syspackage p
where sysEntries <> 0
;x;
group by rollup(pcSeq)
order by pcSeq
;x; -----------
select substr(creator, 1, 8) cre, substr(owner, 1, 8) owner, count(*)
from sysibm.syspackage
where timestamp > '2012-08-01-00.00.00'
group by creator, owner
with ur
;x;
with m (m, x) as
( select trunc_timestamp(current timestamp, 'mon') , 0
from sysibm.sysDummy1
union all select m - 1 month, x+1
from m where x < 30
)
, t (m, cTst) as
(
select trunc_timestamp(timestamp, 'mon'), count(*)
from sysibm.syspackage
group by trunc_timestamp(timestamp, 'mon')
)
, p (m, cPC) as
(
select trunc_timestamp(pctimestamp, 'mon'), count(*)
from sysibm.syspackage
group by trunc_timestamp(pctimestamp, 'mon')
)
select substr(char(m.m), 1, 7) mon, cTst, cPc
from m left join p on m.m = p.m
left join t on m.m = t.m
order by m.m desc
with ur
;X;
select trunc_timestamp(timestamp, 'mon'), count(*)
from sysibm.syspackage
group by trunc_timestamp(timestamp, 'mon')
order by trunc_timestamp(timestamp, 'mon') desc
with ur
}¢--- A540769.WK.SQL(CATPKSYS) cre=2016-10-21 mod=2016-10-21-09.48.37 A540769 ---
select *
from sysibm.syspksystem
where name = 'MF0000'
}¢--- A540769.WK.SQL(CATPLAN) cre=2012-08-28 mod=2016-11-03-09.21.05 A540769 ---
$#@
$=dbSy=dbtf
call sqlConnect $dbSy
call sqlSel "select p.NAME, l.SEQNO, l.LOCATION, l.COLLID, l.NAME",
"from sysibm.sysPlan p",
"left join sysibm.sysPackList l",
"on l.planName = p.name",
"where p.name like 'M%'",
"order by 1, 2"
$|
$$- $dbSy date('s')
call fmtFTab
$#out 20120828 17:13:03
dbtf 20120828
NAME NO LOCATION COLLID COL5
}¢--- A540769.WK.SQL(CATRTS) cre=2011-07-29 mod=2016-11-04-11.01.05 A540769 ----
with r as
(
select r.*, s.pgSize
, case when r.nPages > 0 then 'p'
when r.nPages = 0 then '0'
when r.nPages < 0 then '-'
else '?' end
|| case when r.nPages < r.nActive then '<'
when r.nPages = r.nActive then '='
when r.nPages > r.nActive then '>'
else '?' end
|| case when r.nActive > 0 then 'a'
when r.nActive = 0 then '0'
when r.nActive < 0 then '-'
else '?' end
|| case when r.nActive < r.space * s.pgSize then '<'
when r.nActive = r.space * s.pgSize then '='
when r.nActive > r.space * s.pgSize then '>'
else '?' end
|| case when r.space > 0 then 's'
when r.space = 0 then '0'
when r.space < 0 then '-'
else '?' end txt
from sysibm.sysTableSpaceStats r
join sysibm.sysTableSpace s
on r.dbid = s.dbid and r.psid = s.psid
)
select count(*), txt
, sum(bigint(R.nPages)) nPag
, sum(bigint(R.nActive)) nACt
, sum(bigint(r.nPages)*pgSize) kPag
, sum(bigint(r.nActive)*pgSize) kAct
, sum(r.space) spc
, min(strip(dbName) ||'.'|| strip(name) ||'#'|| partition) dbTsMin
, max(strip(dbName) ||'.'|| strip(name) ||'#'|| partition) dbTsMax
from r
group by txt
order by txt
with ur
;x;
select count(*), DBID, psid, partition,instance, updatestatstime
from sysibm.sysTableSpaceStats
group by DBID, psid, partition,instance, updatestatstime
order by 1 desc
fetch first 100 rows only
with ur
;x;;;;;
select COPYUPDATEDPAGES ,
COPYCHANGES ,
COPYUPDATELRSN, timestamp(copyUpdateLrsn || x'0000') ,
COPYUPDATETIME,
r.*
from sysibm.sysTableSpaceStats r
where copyUpdateLrsn is not null
or copyUpdateTime is not null
or COPYUPDATEDPAGES <> 0
or COPYCHANGES <> 0
order by copyUpdateTime asc
fetch first 1000 rows only
with ur
;x;
select dbName, name, partition, totalrows, space
from sysibm.sysTablespaceStats
where dbName = 'WI02A1T' and name = 'A100H'
select dbName, name, partition, totalrows, space
from sysibm.sysTablespaceStats
where dbName = 'WI02A1T' and name = 'A100H'
;x;
select count(*), sum(r.space), count(r.space),
min(pageSave), max(PageSave)
from sysibm.sysTableSpaceStats r, sysibm.sysTablePart p
where r.dbName = 'MF01A1P' and r.Name = 'A150A'
and r.dbName = p.dbName and r.name = p.tsName
and r.partition = p.partition
and r.partition >= 133
with ur
;
;elect substr(strip(r.dbName) || '.' || strip(r.indexSpace)
|| '+' || strip(r.creator) || '.' || strip(r.name)
|| '/' || strip(char(r.psid)) , 1, 50) "rts",
substr(strip(i.dbName) || '.' || strip(i.indexSpace)
|| '+' || strip(i.creator) || '.' || strip(i.name)
|| '/' || strip(char(s.psid)) , 1, 50) "i",
r.*
from sysibm.sysIndexSpaceStats r,
sysibm.sysIndexes i,
sysibm.sysTables t,
sysibm.sysTableSpace s
where r.dbId = i.dbid and r.isobid = i.isoBid
and i.tbCreator = t.creator and i.tbName = t.name
and t.dbName = s.dbName and t.tsName = s.name
and (r.dbName <> i.dbName or r.indexSpace <> i.indexSpace
or r.creator<> i.creator or r.name <> i.name
or r.psid <> s.psid)
order by r.dbName, r.name
with ur
;x;
select substr(strip(s.dbName) || '.' || strip(s.name), 1, 20) "sDbTs",
substr(strip(r.dbName) || '.' || strip(r.name), 1, 20) "rtsDbTs",
r.*
from sysibm.sysTableSpaceStats r,
sysibm.sysTableSpace s
where r.dbId = s.dbid and r.psid = s.psId
and (r.dbName <> s.dbName or r.name <> s.name)
order by r.dbName, r.name
with ur
;x;
select * from old table (
delete
from sysibm.sysTableSpaceStats r
where (strip(r.dbName) || '*' || strip(r.name))
<> (select strip(s.dbName) || '*' || strip(s.name)
from sysibm.sysTableSpace s
where r.dbId = s.dbid and r.psid = s.psId)
)
order by dbName, name
;
rollback;
;x;
and (r.dbName <> s.dbName or r.name <> s.name)
order by r.dbName, r.name
delete from sysibm.sysTableSpaceStats r
substr(strip(r.dbName) || '.' || strip(r.name), 1, 20) "rtsDbTs",
r.*
from sysibm.sysTableSpaceStats r,
sysibm.sysTableSpace s
where r.dbId = s.dbid and r.psid = s.psId
and (r.dbName <> s.dbName or r.name <> s.name)
order by r.dbName, r.name
}¢--- A540769.WK.SQL(CATRTSMI) cre=2016-10-20 mod=2016-10-20-14.28.04 A540769 ---
-- find RTS with bad values
-- which reorg complains as missing
select *
from sysibm.sysTableSpaceStats
where nActive < 0 or nActive > 1e9
or nPages < 0 or nPages > 1e9
or extents < 0 or extents > 1e3
or totalRows < 0 or totalRows > 1e12
or dataSize < 0 or dataSize > 1e12
}¢--- A540769.WK.SQL(CATSYN) cre=2012-04-16 mod=2016-11-03-09.19.58 A540769 ----
select 'set current sqlid = ''' || strip(creator) || '''; '
|| 'drop synonym ' || strip(name)
|| '; --> ' || strip(tbcreator) || '.' || strip(tbname)
|| ' ' || char(createdts)
from sysibm.syssynonyms
where tbName like 'TAV%'
union all select 'set current sqlid = ''S100447'';'
from sysibm.sysDummy1
union all select 'drop alias ' || strip(creator) || '.' || strip(name)
|| '; --> ' || strip(tbcreator) || '.' || strip(tbname)
|| ' ' || char(createdts)
from sysibm.sysTables
where type = 'A'
and tbName like 'TAV%' and creator not like 'OA1%'
union all select 'drop view ' || strip(creator) || '.' || strip(name)
|| '; --' || char(createdts)
from sysibm.sysTables
where type = 'V'
and name like 'V11'
$#out 20120418 10:05:00
COL1
set current sqlid = 'S100447';
1 rows fetched: select 'set current sqlid = ''' || strip(creator) || '''; ...
$#out 20120418 10:04:38
sqlCode 0: set current sqlid = 'A467700'
sqlCode 0: drop synonym TAV001A1
}¢--- A540769.WK.SQL(EXSCHEMA) cre=2016-11-12 mod=2016-11-12-16.04.00 A540769 ---
select current sqlid, current schema from sysibm.sysDummy1;
set current sqlid = 'S100447';
select current sqlid, current schema from sysibm.sysDummy1;
set current schema = user;
select current sqlid, current schema from sysibm.sysDummy1;
set current schema = oa1p;
select current sqlid, current schema from sysibm.sysDummy1;
set current sqlid = 'A540769';
select current sqlid, current schema from sysibm.sysDummy1;
select * from abc
}¢--- A540769.WK.SQL(GBGRSEL) cre=2013-08-26 mod=2016-10-26-08.39.40 A540769 ---
set current path oa1p;
select substr(fqzfmtBin7(1024.0 * pgSize * nPages), 1, 7) used
, substr(fqzfmtBin7(1024.0 * pgSize * nActive), 1, 7) spc
, dbName, name, partition
, a.*
from OA1P.TQZ006GBGRTsSTATS a
where rz = 'RZ2' and dbSys = 'DVBP'
-- and name = 'SFJ30011'
-- and dbname = 'XBFJ3001'
-- and partition = 24
and validBegin <= current timestamp
and validEnd > current timestamp
order by real(pgSize) * max(value(abs(nActive), 0)
, value(abs(nPages), 0)) desc
-- order by validBegin desc
-- fetch first 100 rows only
with ur
;x;
where dbname = 'ND01A1P' and tsName = 'IND003A1'
and dsNum in (0,4)
;x;
select rz, dbSys, dbName, indexSpace, creator, name, partition
, min(validBegin) validBegin, min(updatestatsTime) updateStats
, LOADRLASTTIME, REBUILDLASTTIME, REORGLASTTIME
from OA1P.TQZ007GBGRIxSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and name = 'VTXINSTRFLATDATA1'
and dbname = 'VV21A1P'
-- and real(pgSize) * nActive > 20000000
-- and partition = 41
-- and validBegin >= current timestamp - 1000 days
-- and validEnd > current timestamp
group by rz, dbSys, dbName, indexSpace, creator, name, partition
, LOADRLASTTIME, REBUILDLASTTIME, REORGLASTTIME
order by 7, 8 desc
-- fetch first 5 rows only
; xx
set current path oa1p;
select -- rz, dbSys, dbName, count(*) parts--, sum(real(nActive)) pages
partition, updateStatsTime
, substr(fqzfmtBin7(1024.0 * pgSize * nPages), 1, 7) used
, substr(fqzfmtBin7(1024.0 * pgSize * nActive), 1, 7) spc
, substr(fqzfmtE7(reorgDeletes), 1, 7) deletes
, reorgLastTime
, substr(fqzfmtE7(totalRows), 1, 7) rows
, 1024.0 * pgSize * nPages / max(1, totalRows) rowBy
, a.*
from OA1P.TQZ006GBGRTsSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
-- and name = 'VTXINSTRFLATDATA1'
and dbname = 'VV21A1P'
-- and real(pgSize) * nActive > 20000000
-- and partition = 41
-- and validBegin >= current timestamp - 1000 days
-- and validEnd > current timestamp
-- group by rz, dbSys, rollup(dbName)
order by rz,dbSYs, dbName, name, partition, validBegin desc
fetch first 5 rows only
; xx
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
;;;;
order by dbName, name, partition, validBegin desc ;x;
and current timestamp between validBegin and validEnd
group by rz, dbSys
--- temporary explain --------------------------------------------------
set current sqlid = 'A540769';
set current application compatibility 'V11R1';
select *
from OA1P.TQZ007GBGRIXSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName = 'FI04A1P' and ts = 'A060A'
order by dbName, ts, name, partition, validBegin desc ;x;
select *
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName = 'FI04A1P' and name = 'A060A'
order by dbName, name, partition, validBegin desc ;x;
and current timestamp between validBegin and validEnd
group by rz, dbSys
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
with s as
(
select sum(real(nActive) * pgSize * 1024) actB
, count(*) parts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name) ts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ) db
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName like 'MF%'
and current timestamp between validBegin and validEnd
group by rz, dbSys
)
select * from s
;
explain plan set queryno = 7 for
with d (d, l) as
(
select current timestamp, 0 from sysibm.sysDummy1
union all select d- 7 days, l+1 from d where l < 1
)
, s as
(
select sum(real(nActive) * pgSize * 1024) actB
, count(*) parts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name) ts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ) db
from OA1P.TQZ006GBGRTSSTATS, d
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName like 'MF%'
and d >= validBegin
and d < validEnd
group by d, rz, dbSys
)
select * from s
;
explain plan set queryno = 9 for
with d (d, l) as
(
select current timestamp, 0 from sysibm.sysDummy1
union all select d- 7 days, l+1 from d where l < 1
)
, s as
(
select sum(real(nActive) * pgSize * 1024) actB
, count(*) parts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name) ts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ) db
from OA1P.TQZ006GBGRTSSTATS a, d
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName like 'MF%'
and d + 0 seconds between validBegin and validEnd
group by d, rz, dbSys
)
select * from s
;
explain plan set queryno = 13 for
with d (d, l) as
(
select current timestamp, 0 from sysibm.sysDummy1
union all select d- 7 days, l+1 from d where l < 1
)
, s as
(
select 0 l
, sum(real(nActive) * pgSize * 1024) actB
, count(*) parts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name) ts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ) db
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName like 'MF%'
and validBegin <= (select d from d where l = 0)
and validEnd > (select d from d where l = 0)
group by rz, dbSys
)
select * from s
;
explain plan set queryno = 22 for
with s ( l,d, actB, parts, tss, dbs) as
(
select 0, current timestamp
, sum(real(nActive) * pgSize * 1024)
, count(*)
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name)
, count(distinct rz ||'/'|| dbSys ||':'|| dbName )
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
-- and dbName like 'MF%'
and validBegin <= current timestamp
and validEnd > current timestamp
group by rz, dbSys
union all select 1, current timestamp - 7 days
, sum(real(nActive) * pgSize * 1024)
, count(*)
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name)
, count(distinct rz ||'/'|| dbSys ||':'|| dbName )
from OA1P.TQZ006GBGRTSSTATS
where rz = 'RZ2' and dbSys = 'DBOF'
-- and dbName like 'MF%'
and validBegin <= current timestamp - 7 days
and validEnd > current timestamp - 7 days
group by rz, dbSys
)
select * from s
;
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
;
select * from dsn_predicat_table
order by collid, progName, explain_time,
queryNo, qBlockNo, predNo -- , orderNo, mixOpSeqNo
with ur
;
rollback
;;;;
with s as
(
select sum(real(nActive) * pgSize * 1024) actB
, count(*) parts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ||'.'|| name) ts
, count(distinct rz ||'/'|| dbSys ||':'|| dbName ) db
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DBOF'
and dbName like 'MF%'
and current timestamp between validBegin and validEnd
group by rz, dbSys
)
select * from s
;
select lastDataChange
, oa1p.fQzFmtBin2(actB) act
, dbName, name, partition
, s.*
from s
where actB > 12e9
order by value(lastDataChange, '2015-04-15-00.00.00') desc
, dbName, name, partition
fetch first 1000 rows only
with ur
;x;
with s as
(
select rz, dbSys, date(validBegin) val, date(updateSTatsTime) updStats
from OA1P.TQZ007GBGRIXSTATS a
where rz = 'RR2' and validBegin > current timestamp - 35 days
)
select rz, dbSys, val, updStats, count(*)
from s
group by rz, dbSys, val, updStats
order by 1,2,3 desc, 4 desc
;x;
select rz, dbSys, loadTs, count(*)
, min(updateStatsTime) updateStats, max(updateStatsTime)
, min(validBegin) validBegin, max(validBegin)
, min(validEnd) validEnd, max(validEnd)
, min(dbName || '.' || name || '#' || partition)
from OA1P.TQZ007GBGRIXSTATS a
where rz = 'RZ2' and validBegin > current timestamp - 15 days
group by rz, dbSys, loadTs
order by 1,2,3 desc
;x;
select count(*), state
from OA1P.TQZ006GBGRTSHJJJ
group by state
;x
select rz, dbSys, loadTs, count(*)
, min(dbName || '.' || name || '#' || partition)
from OA1P.TQZ007GBGRIXNew a
group by rz, dbSys, loadTs
order by 1,2,3,4 desc
;x;
select rz, dbSys, dbName, name, partition,instance
, validBegin, validEnd, updateStatsTime, loadTs, o.*
from OA1P.TQZ006GBGRTSNew o
where rz = 'RR2' and dbSys = 'DP2G' -- and dbName = 'MF01A1P'
and validBegin > '2016-01-07-00.00.00'
-- and name = 'A311A'
order by 7 desc
-- order by 1, 2, 3, 4, 5, 6, 7 desc
;x;
select rz, dbSys, dbName, name, partition,instance
, validBegin, validEnd, updateStatsTime, loadTs, n.*
from OA1P.TQZ006GBGRTSNew n
where rz = 'RZZ' and dbSys = 'DE0G' and dbName = 'MF01A1P'
and name = 'A311A'
order by 1, 2, 3, 4, 5, 6, 7 desc
;x;
select rz, dbSys, dbName, name, partition,instance
, max(validBegin)
from OA1P.TQZ006GBGRTSNew n
group by rz, dbSys, dbName, name, partition,instance
order by 1, 2, 3, 4, 5, 6, 7 desc
;x;
set current path oa1p;
select rz, dbSys, state, loadTs, count(*)
, min(dbName || '.' || name || '#' || partition)
from OA1P.TQZ007GBGRIXSTATS a
where rz = 'RZ2' and updatestatsTime > current timestamp - 3 days
group by rz, dbSys, state, loadTs
order by 1,2,3,4 desc
;x;
update
sysibm.sysTableSpaceStats
set npages = 600000
, totalRows = 6000000
where dbName = 'QZ01A1P' and name = 'A007A' and partition = 2
;
select *
from sysibm.sysTableSpaceStats
where dbName = 'QZ01A1P' and name = 'A006A' and partition = 2
;
commit
;x;
select count(*)
from OA1P.TQZ007GBGRIXSTATS a
where rz = '?'
;x;
select rz, dbSys, state, loadTs, count(*)
, min(dbName || '.' || name || '#' || partition)
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZZ' and updatestatsTime > current timestamp - 2 days
group by rz, dbSys, state, loadTs
order by 1,2,3,4 desc
;x;
select dbName, name, partition
, fosFmte7(real(real(nActive) * pgSize / 1048576)) actGB
, updatestatstime, totalRows, nActive
, a.*
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DVBP'
and dbName = 'XBDG6002'
and name = 'SDG60063'
-- and partition = 7
order by partition, updatestatstime desc
;x;
select count(*), rz, dbSys, max(updateStatsTime) upd, max(loadTs)
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RR2' and loadTs > current timestamp - 20 days
and updateStatsTIme > current timestamp - 20 days
group by rz, dbSys, loadTs
order by 2, 3, 4 desc
;x;
select *
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2' and dbSys = 'DVBP' and dbName = 'XBFJ3002'
and name = 'SFJ30022' and partition in (11, 14, 19)
;x;
with t2 as
(
select rz, dbSys, dbName, name
, partition, instance
, max(loadTs) loadTs
, max(case when loadTs > '2015-05-18-00.00.00'
then null else loadTs end) loadBef
from OA1P.TQZ006GBGRTSSTATS a
where rz = 'RZ2'
and dbName = 'XC01A1P' and name = 'A501A'
and loadTs < '2015-05-20-00.00.00'
group by rz, dbSys, dbName, name, partition, instance
)
select a.*
from t2 join OA1P.TQZ006GBGRTSSTATS a
on a.rz = t2.rz and a.dbSys = t2.dbSys
and a.dbName = t2.dbName and a.name = t2.name
and a.instance = t2.instance and a.partition = t2.partition
and a.loadTs in ( t2.loadTs, t2.loadBef)
order by t2.rz, t2.dbSys, t2.dbName, t2.name
, t2.instance, t2.partition, a.loadTs desc
;x;
, t as
(
select t.rz, t.dbSys, t.dbName, t.Name, min(t.tsTy) tsTy
, smallInt(t.partition * t.limPart) partition
, t.instance
, min(t.limGb) limGb
, min(t.parts) parts
, min(t.clone) clone
, min(t.tsInst) tsInst
, real(sum(real(t.nActive) * t.pgSize / 1048576)) actGB
from OA1P.TQZ006GBGRTSSTATS t join t2 a
select *
from oa1p.tqz006gbgrTsStats
where rz = 'RZ2'
and dbName = 'XC01A1P' and name = 'A501A'
and loadTs >= '2015-05-01-00.00.00'
order by loadTs desc
;x;
select count(*) c, rz, dbSys, loadTs
from oa1p.tqz006gbgrTsStats
where rz = 'RZ2'
and loadTs >= '2015-02-22-00.00.00'
group by rz, dbSys, loadTs
order by rz, dbSys, loadTs
;x;
select date(loadTs), max(updateStatsTime)
from oa1p.tqz006gbgrtsStats
where rz = 'RR2' and dbSys = 'DBOF'
-- and dbName = 'WB11A1P'
-- and name = 'A704A'
-- and partition = 343
-- and loadTs >= '2014-12-01-00.00.00'
group by date(loadTs)
order by 1 desc
;x;
order by rz, dbSys, dbName, name, partition, updatestatstime desc
;x;
with d as
(
select count(*) c, rz, dbSys, dbName
from oa1p.tqz007gbgrixStats
where rz = 'RZZ' and loadTs >= '2014-07-16-00.00.00'
group by rz, dbSys, dbName
)
select sum(c) over(partition by rz, dbSys
order by dbName
)
, d.*
from d
order by rz, dbSys, dbName
;x;
select count(*), rz, dbSys, loadTs
from oa1p.tqz006gbgrtsStats
where rz <> '?'
group by rz, dbSys, loadTs
order by rz, dbSys, loadTs desc
;x;
with t2 as
(
select rz, dbSys, dbName, name
, partition, instance, max(loadTs) loadTs
from OA1P.TQZ006GBGRTSSTATS a
group by rz, dbSys, dbName, name, partition, instance
)
, t as
(
select t.rz, t.dbSys, t.dbName, t.Name, min(t.tsTy) tsTy
, smallInt(t.partition * t.limPart) partition
, t.instance
, min(t.limGb) limGb
, min(t.parts) parts
, min(t.clone) clone
, min(t.tsInst) tsInst
, real(sum(real(t.nActive) * t.pgSize / 1048576)) actGB
from OA1P.TQZ006GBGRTSSTATS t join t2 a
on t.rz = a.rz
and t.dbSys = a.dbSys
and t.dbName = a.dbName
and t.Name = a.Name
and t.partition = a.partition
and t.instance = a.instance
and t.loadTS = a.loadTs
group by t.rz, t.dbSys, t.dbName, t.Name
, smallInt(t.partition * t.limPart)
, t.instance
)
, i2 as
(
select rz, dbSys, dbName, ts, indexSpace
, partition, instance, max(loadTs) loadTs
from OA1P.TQZ007GbGrIxSTATS a
group by rz, dbSys, dbName, ts, indexSpace, partition, instance
)
, i as
(
select i.*
, real(real(nActive) * ixPgSz / 1048576) actGB
from OA1P.TQZ007GBGRIxSTATS i join i2 a
on i.rz = a.rz
and i.dbSys = a.dbSys
and i.dbName = a.dbName
and i.ts = a.ts
and i.indexSpace= a.indexSpace
and i.partition = a.partition
and i.instance = a.instance
and i.loadTS = a.loadTs
)
, u (limGb, actGb, db, ts, ix, part, inst, rz, dbSys
, tsTy, tsLimGb, tsParts, tsClone, tsInst) as
(
select limGb, actGb, dbName, name, ' --ts--'
, partition, instance, rz, dbSys
, tsTy, limGb, parts, clone , tsInst
from t
union all select limGb, actGb, dbName, ts , name
, partition, instance, rz, dbSys
, tsTy, tslimGb, tsParts, tsClone, tsInst
from i
)
, s as
(
select u.*
, (select max(info) from oa1p.tqz008GbGrSchweExp e
where e.rz = u.rz and e.dbSys = u.dbSys
and left(e.db , e.dbLen) = left(u.db , e.dbLen)
and left(e.ts , e.tsLen) = left(u.ts , e.tsLen)
and e.part in(u.part, 0)
and e.tsTy in (u.tsTy, ' ')
and e.dsMin <= u.tslimGB
and validBegin <= current date
and validEnd > current date
) schwInfo
from u
)
, v as
(
select int(case when schwInfo is not null
then int(substr(schwInfo, 16, 6))
else raise_error(70001, 'schwelle null ts='
|| db || '.' || ts || '#' || part)
end) schwelle
, s.*
from s
-- order by db, ts, part, ix
)
select substr(db, 1, 8) "db"
, substr(ts, 1, 8) "ts"
, substr(ix, max(1, length(ix) - 7), 8) "...index"
, substr(case when part = 0 and tsParts = 0 then ''
else case when part = 0 then ' npi'
else value(right(' ' || part, 4), '----') end
||'/'|| value(right(' '||strip(char(tsParts)), 4),'----')
end, 1, 9) "part/ tot"
, substr(right(case when actGB < 1000
then ' ' || dec(round(actGb, 2), 6, 2)
else ' ' || int(round(actGb, 0))
end, 7), 1, 7) "usedGB"
, substr(right(case when limGb/100*schwelle < 1000
then ' ' || dec(round(limGb/100*schwelle, 2), 6, 2)
else ' ' || int(round(limGb/100*schwelle, 0))
end, 7), 1, 7) "schwGB"
, substr(right(' ' || schwelle, 5), 1, 5) "schw%"
, substr(right(' ' || int(round(limGb)), 6), 1, 6) "limGB"
, tsTy "y"
, substr(schwinfo, 23) "schwellwert key"
from v
where -- actGb > real(limGb / 100 * schwelle)
db like 'MF01%'
and db <> 'DSNDB01' -- directory ist anders
and rz = 'RZ2' and dbSys = 'DBOF'
order by db, ts, ix, part, ix
;x;
select *
from OA1P.TQZ007GBGRixSTATS a
where rz = 'RZ2' and dbSys = 'DBOF' and dbName = 'MF01A1P'
and name like 'IMF150A%'
;x;
select count(*), date(loadTs)
from oa1p.tqz006gbgrtsStats
-- where rz = 'RZ2'
group by date(loadTs)
order by date(loadTs) desc
;x;
insert into oa1p.tqz006GbGrTsStats
(state, rz, dbSys, dbName, name, partition, instance
, pgSize, tsType, nTables, parts, maxParts, dsSize
, segSize, tsTy, dsGB, clone, tsInst, tbCr, tb, tbTy, tbId
, dbid, obid, psid, ibmReqD
, updateStatsTime)
with s as
(
select row_number()
over (partition by dbName, name, partition, instance
order by loadDt desc, updateStatsTime desc) rn
, s.*
from oa1p.tqz006GbGrTsStats s
where rz = 'RZ4' and dbSys = 'DP4G' and state <> 'd'
fetch first 100 rows only
)
select 'd', rz, dbSys, dbName, name, partition, instance
, pgSize, tsType, nTables, parts, maxParts, dsSize
, segSize, tsTy, dsGB, clone, tsInst, tbCr, tb, tbTy, tbId
, dbid, obid, psid, ibmReqD
, (select max(updateStatsTime)
from oa1p.tqz006GbGrTsStats n
where n.rz = '?' and n.dbSys = '?'
)
from s
where rn = 1
and not exists (select 1
from oa1p.tqz006GbGrTsStats n
where n.rz = '?' and n.dbSys = '?'
and n.dbName = s.dbName
and n.Name = s.Name
and n.partition = s.partition
and n.instance = s.instance
)
;
commit
;x;
with s as (
select
s.pgSize, s.type tsType, s.nTables
, s.partitions parts, s.maxPartitions maxParts, s.dsSize
, s.segsize
, char(value(case
when s.type <> ' ' then s.type
when partitions > 0 and segsize = 0 then 'p' -- classic part
when partitions = 0 and segsize = 0 then 'i' -- simple
when partitions = 0 and segsize > 0 then 's' -- segmented
else raise_error(70101, 'unknown ts type='||s.type
|| ' partitions=' || strip(char(partitions))
|| ' segsize=' || strip(char(segsize))
|| ' db.ts=' || strip(s.dbName) ||'.'||s.name)
end, '?'), 1) tsTy
, smallInt(value(case
when dssize <> 0 then int(dssize / 1048576)
when s.type in ('G', 'O', 'P', 'R', 'L') then 4
when partitions = 0 then 64
when partitions > 254 then pgSize
when partitions > 64 then 4
when partitions > 32 then 1
when partitions > 16 then 2
else 4
end, -99)) dsGB
, s.obid, s.clone, s.instance tsInst
, value(t.creator, '') tbCr
, value(t.name, case when nTables = 0 then 'none'
when nTables > 1 then 'multi'
else 'missing' end) tb
, value(t.type, '') tbTy
, smallint(value(t.obId, 0)) tbId
, r.*
from sysibm.sysTableSpaceStats r
join sysibm.sysTablespace s
on r.dbName = s.dbName and r.name = s.name
and r.dbId = s.dbId and r.psid = s.psid
left join sysibm.sysTables t
on s.nTables = 1
and t.dbName = s.dbName and t.tsName = s.name
and ( (t.type not in ('A', 'V', 'C', 'G')
and s.instance = r.instance)
or (t.type = 'C' and s.instance <> r.instance))
)
select dbName, name, partition, instance, count(*)
from s
group by dbName, name, partition, instance
order by 5 desc
;x;
select rz, dbSys, count(*)
from oa1p.tQz006GbGrTsMeta
group by rz, dbSys
;x;
select *
from S100447.tGbGrSchwelle
;
select *
from S100447.tGbGrSchwHist
}¢--- A540769.WK.SQL(GBGRSPC) cre=2014-10-09 mod=2016-11-14-07.16.47 A540769 ---
$#:
$*( -------------------------------------------------------------------
spaceQuery wsh : dynamische Abfragen auf GbGrIxStats & GbGrTsStats
: per Stichdatum oder Zeitreihe
: verschieden Gruppierungen und zwischentotalbe
--------------------------------------------------------------------$*)
*--- Function -----------------
fun = o $** b=batchjob, s=sql anzeigen, o=online sql
*--- Timeseries ---------------
intCnt = 10 $** Anzahl Intervale, 0 = ein einzige Stichdatum
intLen = 1 $** Länge eines intervalls, numerisch
$=intTyp = day $** Intervall-"Typ" day, month, year
$=startDate = % $** Startdatum (von da rückwärts). %=heute
*--- Selection Criteria -------
$=inRZ = RZX $** RZ. Auch % erlaubt
$=inSys = DEVG $** Subsystem. Auch % erlaubt
$=inDB = DB2PLAN $** Datenbank. % erlaubt
$=inTS = CMNBA% $** Tablespace. % erlaubt
inPart = % $** Partition. Numerisch oder % für alle
rows = 20000 $** Rowlimit
*--- Detail/Group Level von "r" bis "rsdtip"
*--- definiert die "Gruppierungsstufe"
rol = rsdt $** R RZ - obligatorisch
$** rS DB-Subsystem
$** rsD Datenbank
$** rsdT Tablespace
$** rsdtI Indexspaces
$** rsdtP Partitionslevel TS
$** rsdtiP Partitionslevel TS+IX
*-- order ---------------------
order = A
$** order by : A 'alphabtical' : with total on top'
$** T 'Totals first : Total, Subtotals, Detailrows
$** S 'Space' : total first, then ordered by space
$*(----------------------------------------------
mainFunction: fun
o (online) führt SQL aus
b (batch) erzeugt batchjob mit sql
s (sql) zeigt aufgelöstes SQL
------------------------------------------------$*)
$@/mainFun/
if $fun = 'o' then $@¢
$@work
call sqlConnect
$| call sqlStmts
$>. fEdit('::v')
$! else if $fun = 'b' then $@=¢
$>. fEdit()
//$-¢userid()$!W JOB (SMM27862,0240,,3612),'DSNTEP2',
// MSGCLASS=T,TIME=1440,SCHENV=DB2ALL,
// NOTIFY=&SYSUID,CLASS=M1
//*--------------------------------------------------
//* dsnTep2 fuer gbgrSpace query
//*--------------------------------------------------
//RUNSQL EXEC PGM=IKJEFT01,PARM='%WSH s #'
//OUT DD SYSOUT=*,DCB=(LRECL=32756,BLKSIZE=32760,RECFM=VBA)
//SYSPROC DD DISP=SHR,DSN=DSN.DB2.EXEC
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//WSH DD *
$@prParm
$@work
$! else if $fun = 's' then $@=¢
$>. fEdit('::v')
$@prParm
$@work
$! else
call err 'please implement fun='$fun
$/mainFun/
$@proc $@=/prParm/ $** write parameters to batch/sql
-- SQL Generated using the following paramaters
-- RZ / SubSystem : $inRZ / $inSys
-- Database : $inDB
-- Tablespace : $inTS
-- Partition : $inPart
-- Grouping Level : $rol
-- Sort mode : $order
-- $intCnt intervals of $intLen $intTyp
$/prParm/
$** ----------------------------------------------
$** MAIN PRODECURE "/WORK/"
$** ----------------------------------------------
$@proc $@=/work/
$= rol =- ut2lc($rol)
$@ cols = ''
$= timevar = $''
$do rx=1 to length($rol) $@¢
q = substr($rol, rx, 1)
if q == 'r' then
cols = 'rz'
else if q == 's' then
cols = cols', dbsys'
else if q == 'd' then
cols = cols', dbName'
else if q == 't' then
cols = cols', ts'
else if q == 'i' then
cols = cols', indexSpace'
else if q == 'p' then
cols = cols', partition'
else
call err 'bad col' q rx 'in $rol ' $rol
$!
$= rolCol =- substr(cols, 3)
$= rolCol =- cols
$** BEGIN OF SQL PART --------------------------------------
set current path oa1p;
set current application compatibility 'V11R1';
with d (d,l) as
(
$@ if pos('%',$startDate) > 0 then $@=¢
select timestamp(current date,'12:00:00'),0
$! $@ else $@=¢
select timestamp($startDate,'12:00:00'),0
$!
from sysibm.sysDummy1
union all select d - $intLen $intTyp,l+1
from d
where l < $intCnt
),
tsi as
(
select rz, dbSys, dbName, ts, indexSpace
, partition
, d
, instance
, cast(null as real) tsUsed
, cast(null as bigInt) tsRows
, 0 tsParts
, tsTy tsType
, substr(tbname, 1, 30) table
, real(nActive) * ixPgSz * 1024 iXused
, totalEntries iXEntries
, loadTS loadTS
, updateStatstime updateStatstime
, 1 ixParts
, strip(tbCreator) || '.' || tbName tb
from oa1p.tqz007GbGrIxSTats is join d
on d >= validbegin
and d < validend
where rz <> '?' and dbsys <> '?'
and rz $-^¢eqLike $inRZ $!
and dbSys $-^¢eqLike $inSys $!
and dbName $-^¢eqLike $inDB $!
and ts $-^¢eqLike $inTS $!
$@ if $inPart /= '%' then $@=¢
and partition = $inPart
$!
union all
select rz, dbSys, dbName, name ts, '-table--' as indexSpace
, partition
, d
, instance
, real(nActive) * pgSize * 1024 tsUsed
, totalRows tsRows
, 1 tsParts
, tsTy tsType
, substr(tb, 1, 30) table
, cast(0 as real) ixUsed
, cast(0 as bigInt) ixEntries
, loadTs loadTS
, updateStatsTime updateStatsTime
, 0 ixParts
, strip(tbCr) || '.' || tb tb
from oa1p.tqz006GbGrTsSTats st join d
on d >= validbegin
and d < validend
where rz <> '?' and dbsys <> '?'
and rz $-^¢eqLike $inRZ $!
and dbSys $-^¢eqLike $inSys $!
and dbName $-^¢eqLike $inDB $!
and name $-^¢eqLike $inTS $!
$@ if $inPart /= '%' then $@=¢
and partition = $inPart
$!
)
, roll as (
select $rolCol, d
, case when min(table) = max(table)
then min(table)
else null
end table
, sum(tsUsed) tsUsed
, sum(tsRows) tsRows
, sum (tsParts) tsParts
, sum (iXused) ixused
, value (sum(ixUsed), 0)
+ value(sum(tsUSed), 0) totused
, sum (iXEntries) ixEntries
, sum (iXParts) ixParts
, case when max(tsType) = min(tsType)
then max(tsType)
else 'div'
end tsType
, max(loadTs) loadTsMax
, max(updateStatsTime) statsTimeMax
, min(loadTs) loadTsMin
, min(updateStatsTime) statsTimeMin
, count(distinct rz) cRZ
, count(distinct rz || '/' ||
dbSys) cSys
, count(distinct rz || '/' ||
dbSys || ':' || strip(dbName)) cDB
, count(distinct rz || '/' ||
dbSys || ':' || strip(dbName) ||
'.' || strip(ts) ) cTS
, count(distinct rz || '/' ||
dbSys || ':' || strip(dbName) ||
'.' || strip(ts) || '#' || partition) cTP
, count(distinct rz || '/' || dbSys ||
':' || strip(dbName)|| '.' ||strip(ts)
|| '#'||strip(indexSpace)) cIS
, count(distinct rz || '/' || dbSys ||
':'||strip(dbName)||'.'||strip(ts)
|| '#' || strip(indexSpace)
|| '#' || partition) cIP
, case when max(tb) = min(tb)
then max(tb) else '#tb=' || count(distinct tb) end tb
from tsi
group by
$@ if $rolCol \== '' then
rollup($rolCol)
, d
)
, tot as (
select max(totUsed) totMax from roll
)
select
rz "RZ"
$@ if pos('s', $rol) > 0 then
, dbSys "dbSys"
, date(d) "Date"
$@ if pos('d', $rol) > 0 then
, value(dbName, '#' || cDb) "dB"
$@ else
, '#' || cDb "dB"
$@ if pos('t', $rol) > 0 then
,value(ts , '#' || cTs) "tableSpace"
$@ else
, '#' || cTs "tableSpace"
$@ if pos('i', $rol) > 0 then
, value(indexSpace , '#' || cIs) "indexSpace"
$@ else
, '#' || cIs "indexSpace"
$@ if pos('p', $rol) > 0 then $@=¢
, case when partition is null
then '#'||cast(cTP as varchar(4))
else cast(partition as char(4))
end "part" $!
, '¦'||repeat('*',round(20 * roll.totused /
(select max(totMax) from tot x))) "spaceDistribution"
, round(100*roll.totused /
(select max(totMax) from tot x),1) ofTotSpace
,fqzfmtbin7(totused) "totalUsed"
,fqzfmtbin7(tsUsed) "tsUsed"
,translate( varchar_format
(tsRows,'999,999,999,999,999')
, '''' ,',') "tsRows"
,tsParts "tsParts"
,fqzfmtbin7(ixUsed) "ixUsed"
,translate( varchar_format
(ixEntries,'999,999,999,999,999')
, '''' ,',') "ixEntries"
,ixParts "ixParts"
,tsTYpe "tsType"
,tb
,table
,case
when rz is null then 0
$@ if pos('s', $rol) > 0 then
when dbSys is null then 1
$@ if pos('d', $rol) > 0 then
when dbname is null then 2
$@ if pos('t', $rol) > 0 then
when ts is null then 3
$@ if pos('i', $rol) > 0 then
when indexSpace is null then 4
$@ if pos('p', $rol) > 0 then
when partition is null then 5
else 99
end rollupLevel
from roll
, tot
$@ if $order = S then $@=¢
$** zuerst alle rollups (nach Level) Details am Schluss
order by rollupLevel,
d desc, ofTotSpace desc
$! $@ else if $order = T then $@=¢
$** zuerst alle rollups (nach Level) Details am Schluss
order by rollupLevel
,rz, dbSys, d desc
$! $@ else $@=¢
$** hierarchische Reihenfolge und redundante rollups enfernt
where 0 = case
$@ if pos('r', $rol) > 0 then
when rz is null and cRZ <= 1 then 1
$@ if pos('s', $rol) > 0 then
when rz is not null and dbSys is null and cSys <= 1 then 1
$@ if pos('d', $rol) > 0 then
when dbSys is not null and dbname is null and cDb <= 1 then 1
$@ if pos('d', $rol) > 0 then
when dbName is null and (cDb <= 1 and cRZ <= 1) then 1
$@ if pos('dt', $rol) > 0 then
when dbName is not null and ts is null and cTs <= 1 then 1
$@ if pos('ti', $rol) > 0 then
when ts is not null and indexSpace is null and cIs <= 1 then 1
$@ if pos('tp', $rol) > 0 then
when ts is not null and partition is null and cTP <= 1 then 1
$@ if pos('ip', $rol) > 0 then
when indexSpace is not null and partition is null and cIP<=1 then 1
else 0 end
order by value(rz,'')
$!
$@ if pos('s', $rol) > 0 then
, value(dbsys, '')
$@ if pos('d', $rol) > 0 then
, value(dbName, '')
$@ if pos('t', $rol) > 0 then
, value(ts, '')
$@ if pos('i', $rol) > 0 then
, value(indexSpace, '')
$@ if pos('p', $rol) > 0 then
, value(partition, -999)
, d desc
fetch first 20000 rows only;
$/work/
$proc $@/eqLike/
parse arg , v
if verify(v, '_%', 'm') < 1 then
return '=' quote(v, "'")
else
return 'like' quote(v, "'")
$/eqLike/
$*****************************************************************************
}¢--- A540769.WK.SQL(PKGCLEAC) cre=2016-10-26 mod=2016-10-31-09.30.41 A540769 ---
$#@ $*( ***************************************************************
report packages for clenaup process for all rz/dbsys
use: wsh >v
28.10.16 Walter neu
******************************************************************* $*)
m.csm_timeout = 90
$**--- over all rz/dbSys ----------------------------------------------
$do ix=1 while iiIxPut(ix) $@¢
say ix $rz '/' $dbSys ii2rzdb($rz'/'$dbSys, 1)
$**if wordPos($rz, 'RQ2 -Q2') < 1 then iterate
call sqlConnect ii2rzDb($rz'/'$dbSys, 1)
$<>
$@sql $| call sqlStmts ,'' , , ,'o'
$| call pipeWriteNow jTalkRdr()
$<>
call sqlDisconnect
$!
$| call fTabAuto fTabReset(ft)
$**--- sql to find and cound packages for cleanup ---------------------
$proc $@=/sql/
set current application compatibility 'V11R1';
with p0 as
( --- ignore packages created in last two weeks ----------------------
select case when timestamp < current timestamp - 15 days
then 0 else 1 end creNew
, 20 win, p.*
from sysibm.syspackage p
)
, p1 as
( --- end of first window before creNew=1
select max(case when creNew = 0 then timestamp end)
over(partition by location, collid, name) cre1
, max(case when creNew = 0 then pcTimestamp end)
over(partition by location, collid, name) pcT1
, max(case when creNew = 0 then lastUsed end)
over(partition by location, collid, name) use1
, p0.*
from p0
)
, p2 as
( --- end of second window before begin of first window ---------------
select max(case when cre1 < '1000-01-01-00.00.00' then null
when creNew = 0 and timestamp < cre1 - win days
then timestamp end)
over(partition by location, collid, name) cre2
, max(case when pcT1 < '1000-01-01-00.00.00' then null
when creNew = 0 and pcTimestamp < pcT1 - win days
then pcTimestamp end)
over(partition by location, collid, name) pcT2
, max(case when use1 < '01.01.1000' then null
when creNew = 0 and lastUsed < use1 - win days
then lastUsed end)
over(partition by location, collid, name) use2
, p1.*
from p1
)
, pS as
( --- seqNumber of each window ----------------------------------------
select
case when creNew = 1 then 0
when cre1 is null or cre1 < '1000-01-01-00.00.00' then 1
when timestamp >= cre1 - win days then 1
when cre2 is null or cre2 < '1000-01-01-00.00.00' then 2
when timestamp >= cre2 - win days then 2
else 9 end creSeq
, case when creNew = 1 then 0
when pcT1 is null or pcT1 < '1000-01-01-00.00.00' then 1
when pcTimestamp >= pcT1 - win days then 1
when pcT2 is null or pcT2 < '1000-01-01-00.00.00' then 2
when pcTimestamp >= pcT2 - win days then 2
else 9 end pcTSeq
, case when creNew = 1 then 0
-- ignore PKGs never used, not after Db2V9, not in 3 years
when lastUsed < current date - 3 years then 9
when use1 is null or use1 < '01.01.1000' then 1
when lastUsed >= use1 - win days then 1
when use2 is null or use2 < '01.01.1000' then 2
when lastUsed >= use2 - win days then 2
else 9 end useSeq
, p2.*
from p2
)
, pR as
( --- reason why to keep or deactivate a package ----------------------
select case
when sysentries > 0 then 'k1sysEnt>0' -- already deact
when sysentries < 0 then 'k2sysEnt<0' -- should not exist
when creNew = 1 then 'k3cre>15d' -- newly created
when pctSeq <= 2 then 'k4pcT<=2' -- last 2 compile
when creSeq <= 2 then 'k5cre<=2' -- last 2 compile
when useSeq <= 2 then 'k6use<=2' -- last 2 lastUsed
when lastUsed > current date - 4 month
then 'k7use<4Mo' -- wait until next zuegelschub
else 'd0deact' end dsr
, pS.*
from pS
)
, p as
( --- decode dsr ------------------------------------------------------
select left(dsr, 1) deact, substr(dsr, 3) reason, pR.*
from pR
)
select '$rz/$dbSys' rzDb
, deact
, reason
, count(*) pkgVers
, count(distinct strip(collid) || '.' || strip(name)) pkg
, sum(case when pctSeq=1 then 1 else 0 end) pcT1
, sum(case when pctSeq=2 then 1 else 0 end) pcT2
, sum(case when useSeq=1 and lastUsed > current date - 3 year
then 1 else 0 end) use1
, sum(case when useSeq=2 and lastUsed > current date - 3 year
then 1 else 0 end) use2
, sum(case when valid = 'N' then 1 else 0 end) validNo
, sum(case when operative = 'N' then 1 else 0 end) operativeNo
from p
group by grouping sets((deact, dsr, reason), (deact), ())
having deact is null or reason is not null
or (reason is null and count(distinct reason) <> 1)
order by value(deact, ' '), value(substr(dsr, 2, 1), '')
with ur
;
$/sql/
}¢--- A540769.WK.SQL(PKGCLEAJ) cre=2016-11-21 mod=2016-11-28-15.16.48 A540769 ---
$#@
m.dsn.1 = PCL.U0000.P0.RZXBAK.PERM.@008.DBR $** backup
m.dsn.2 = PCL.U0000.E0.RZXAKT.PROM.@008.DBR $** Aktiv Promote
m.dsn.3 = PCL.U0000.P0.RZXAKT.PERM.@008.DBR $** Aktiv Prod
m.dsn.0 = 3
do ix=1 to m.dsn.0
call mbrLIst 'MBR.'ix, m.dsn.ix
m.cIx.ix = 1
m.cur.ix = m.mbr.ix.1
end
do forever
do gx=1 to m.dsn.0 while m.cIx.gx > m.mbr.gx.0
end
if gx > m.dsn.0 then
leave
eq = gx
do ix=gx+1 to m.dsn.0
if m.cIx.ix > m.mbr.ix.0 then
iterate
if m.cur.gx == m.cur.ix then do
eq = eq ix
end
else if m.cur.gx >> m.cur.ix then do
gx = ix
eq = ix
end
end
say m.cur.gx eq
do wx=1 to words(eq)
ix = word(eq, wx)
iy = m.cIx.ix + 1
m.cIx.ix = iY
if iY <= m.mbr.ix & m.mbr.ix.iY <<= m.cur.ix then
call err m.mbr.ix.iY '<<=' m.cur.ix 'in' m.dsn.ix
m.cur.ix = m.mbr.ix.iY
end
end
$#out 20161121 11:58:31
$#out 20161121 11:37:43
$#out
}¢--- A540769.WK.SQL(PKGCLEAN) cre=2016-10-24 mod=2016-11-08-12.00.47 A540769 ---
//A540769P JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,
// SCHENV=DB2ALL,CLASS=M1
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='%WSH'
//SYSPROC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$#:
dbSys = DE0G
sqlFree = -117 -203 -204 -206 -408
sqlExpl = -219
$*( *******************************************************************
job to deactivate outdated packages
* this job can be killed and restarted anytime ****************
usage: check/correct dbSys
sub
verify output, if necessary adapt script and resubmit job
function
1) select outdated packageVersions by sql below
that are NOT deactivated yet
2) deactived by rebind enable (cics) cics(loeschen)
if rebind fails becuause of missing explain table
retry with explain(no)
if package is inValid and rebind is not possible
(has (only) sqlCodes from sqlFree above)
then free package
3) sleep 1 second after 10 rebinds
to avoid monopolisation of the catalog
********************************************************************$*)
rCnt = 0
@selPk
| forWith @rebindPk
proc $@/selPk/
call sqlConnect $dbSys
call sqlStmts , , , , 'o'
$| $@. jTalkRdr()
$<=¢
set current application compatibility 'V11R1';
with p0 as
( --- ignore packages created in last two weeks ----------------------
select case when timestamp < current timestamp - 15 days
then 0 else 1 end creNew
, 20 win, p.*
from sysibm.syspackage p
)
, p1 as
( --- end of first window before creNew=1
select max(case when creNew = 0 then timestamp end)
over(partition by location, collid, name) cre1
, max(case when creNew = 0 then pcTimestamp end)
over(partition by location, collid, name) pcT1
, max(case when creNew = 0 then lastUsed end)
over(partition by location, collid, name) use1
, p0.*
from p0
)
, p2 as
( --- end of second window before begin of first window ---------------
select max(case when cre1 < '1000-01-01-00.00.00' then null
when creNew = 0 and timestamp < cre1 - win days
then timestamp end)
over(partition by location, collid, name) cre2
, max(case when pcT1 < '1000-01-01-00.00.00' then null
when creNew = 0 and pcTimestamp < pcT1 - win days
then pcTimestamp end)
over(partition by location, collid, name) pcT2
, max(case when use1 < '01.01.1000' then null
when creNew = 0 and lastUsed < use1 - win days
then lastUsed end)
over(partition by location, collid, name) use2
, p1.*
from p1
)
, pS as
( --- seqNumber of each window ----------------------------------------
select
case when creNew = 1 then 0
when cre1 is null or cre1 < '1000-01-01-00.00.00' then 1
when timestamp >= cre1 - win days then 1
when cre2 is null or cre2 < '1000-01-01-00.00.00' then 2
when timestamp >= cre2 - win days then 2
else 9 end creSeq
, case when creNew = 1 then 0
when pcT1 is null or pcT1 < '1000-01-01-00.00.00' then 1
when pcTimestamp >= pcT1 - win days then 1
when pcT2 is null or pcT2 < '1000-01-01-00.00.00' then 2
when pcTimestamp >= pcT2 - win days then 2
else 9 end pcTSeq
, case when creNew = 1 then 0
-- ignore PKGs never used, not after Db2V9, not in 3 years
when lastUsed < current date - 3 years then 9
when use1 is null or use1 < '01.01.1000' then 1
when lastUsed >= use1 - win days then 1
when use2 is null or use2 < '01.01.1000' then 2
when lastUsed >= use2 - win days then 2
else 9 end useSeq
, p2.*
from p2
)
, pR as
( --- reason why to keep or deactivate a package ----------------------
select case
when sysentries > 0 then 'k1sysEnt>0' -- already deact
when sysentries < 0 then 'k2sysEnt<0' -- should not exist
when creNew = 1 then 'k3cre>15d' -- newly created
when pctSeq <= 2 then 'k4pcT<=2' -- last 2 compile
when creSeq <= 2 then 'k5cre<=2' -- last 2 compile
when useSeq <= 2 then 'k6use<=2' -- last 2 lastUsed
when lastUsed > current date - 123 days
then 'k7use<4Mo' -- wait zuegelschub
else 'd0deact' end dsr
, pS.*
from pS
)
, p as
( --- decode dsr ------------------------------------------------------
select left(dsr, 1) deact, substr(dsr, 3) reason, pR.*
from pR
)
select strip(collid) collid, strip(name) pk, strip(version) vers
, valid, operative, creSeq, useSeq, pctSeq, lastUsed
from p
where deact = 'd'
-- fetch first 1000 rows only
with ur
$!
$/selPk/
proc $@/rebindPk/
$arg explNo
say 'rebindPk' $COLLID'.'$PK'('$VERS')' $*+
'cre='$CRESEQ 'pct='$PCTSEQ 'use='$USESEQ $LASTUSED
rb = 'rebind package('$COLLID'.'$PK'.('$VERS'))',
'enable (cics ) cics(loeschen) planmgmt(extended)' ,
|| copies(' explain(no)', $explNo == 1)
say rb
rr = sqlDsn(bo, $dbSys, rb, '*')
cd = ''
sqlExpl = 0
sqlFree = 0
sqlOth = 0
msg = ''
if rr <> 0 then $@¢
do bx=1 to m.bo.0
sx = pos('SQLCODE=', m.bo.bx)
if sx > 0 then do
c1 = word(substr(m.bo.bx, sx+8), 1)
if wordPos(c1, $sqlExpl) > 0 then
sqlExpl = sqlExpl + 1
else if wordPos(c1, $sqlFree) > 0 then
sqlFree = sqlFree + 1
else
sqlOth = sqlOth + 1
if wordPos(c1, cd) < 1 then
cd = cd c1
end
if word(m.bo.bx, 1) = 'DSNT219I' then
if $VALID = 'N' then
msg = msg 'warn(DSNT219I: ok, but current invalid)'
else
say ' ##dsnt219I but valid='$VALID
end
$!
doFree = sqlFree > 0 & sqlOth == 0
$= rCnt =- $rCnt + 1
say '#rc='rr 'doFree='doFree msg 'sqlCodes='cd 'rb='rb
if rr = 0 then $@¢
$! else if rr=4 & cd = '' & msg <> '' then $@¢
$! else $@¢
do bx=1 to m.bo.0
say ' ' strip(m.bo.bx, 't')
end
if sqlExpl <> 0 then $@¢
if $explNo == 1 then $@¢
say 'explain sqlCode but already explain(no)'
$! else $@¢
say 'retrying with explain no'
$@% rebindPk 1
$!
$! else if doFree then $@¢
fr = 'free package('$COLLID'.'$PK'.('$VERS'))'
say ' trying to' fr
rr = sqlDsn(fo, $dbSys, fr, '*')
say ' rc='rr 'for' fr
if rr <> 0 then do
do fx=1 to m.fo.0
say ' ' strip(m.fo.fx, 't')
end
end
$!
$!
if $rCnt // 10 = 0 then $@¢
say 'after' $rCnt 'rebinds sleeping 1 second' time()
call sleep 1, 0
$!
$/rebindPk/
}¢--- A540769.WK.SQL(PKGCLEAS) cre=2016-10-28 mod=2016-10-31-08.58.22 A540769 ---
set current application compatibility 'V11R1';
with p0 as
( --- ignore packages created in last two weeks ----------------------
select case when timestamp < current timestamp - 15 days
then 0 else 1 end creNew
, 20 win, p.*
from sysibm.syspackage p
)
, p1 as
( --- end of first window before creNew=1
select max(case when creNew = 0 then timestamp end)
over(partition by location, collid, name) cre1
, max(case when creNew = 0 then pcTimestamp end)
over(partition by location, collid, name) pcT1
, max(case when creNew = 0 then lastUsed end)
over(partition by location, collid, name) use1
, p0.*
from p0
)
, p2 as
( --- end of second window before begin of first window ---------------
select max(case when cre1 < '1000-01-01-00.00.00' then null
when creNew = 0 and timestamp < cre1 - win days
then timestamp end)
over(partition by location, collid, name) cre2
, max(case when pcT1 < '1000-01-01-00.00.00' then null
when creNew = 0 and pcTimestamp < pcT1 - win days
then pcTimestamp end)
over(partition by location, collid, name) pcT2
, max(case when use1 < '01.01.1000' then null
when creNew = 0 and lastUsed < use1 - win days
then lastUsed end)
over(partition by location, collid, name) use2
, p1.*
from p1
)
, pS as
( --- seqNumber of each window ----------------------------------------
select
case when creNew = 1 then 0
when cre1 is null or cre1 < '1000-01-01-00.00.00' then 1
when timestamp >= cre1 - win days then 1
when cre2 is null or cre2 < '1000-01-01-00.00.00' then 2
when timestamp >= cre2 - win days then 2
else 9 end creSeq
, case when creNew = 1 then 0
when pcT1 is null or pcT1 < '1000-01-01-00.00.00' then 1
when pcTimestamp >= pcT1 - win days then 1
when pcT2 is null or pcT2 < '1000-01-01-00.00.00' then 2
when pcTimestamp >= pcT2 - win days then 2
else 9 end pcTSeq
, case when creNew = 1 then 0
-- ignore PKGs never used, not after Db2V9, not in 3 years
when lastUsed < current date - 3 years then 9
when use1 is null or use1 < '01.01.1000' then 1
when lastUsed >= use1 - win days then 1
when use2 is null or use2 < '01.01.1000' then 2
when lastUsed >= use2 - win days then 2
else 9 end useSeq
, p2.*
from p2
)
, pR as
( --- reason why to keep or deactivate a package ----------------------
select case
when sysentries > 0 then 'k1sysEnt>0' -- already deact
when sysentries < 0 then 'k2sysEnt<0' -- should not exist
when creNew = 1 then 'k3cre>15d' -- newly created
when pctSeq <= 2 then 'k4pcT<=2' -- last 2 compile
when creSeq <= 2 then 'k5cre<=2' -- last 2 compile
when useSeq <= 2 then 'k6use<=2' -- last 2 lastUsed
when lastUsed > current date - 4 month
then 'k7use<4Mo' -- wait until next zuegelschub
else 'd0deact' end dsr
, pS.*
from pS
)
, p as
( --- decode dsr ------------------------------------------------------
select left(dsr, 1) deact, substr(dsr, 3) reason, pR.*
from pR
)
$** select * from p order by cnt desc fetch first 100 rows only
select '?rz/?dbSys' rzDb
, deact
, reason
, count(*) pkgVers
, count(distinct strip(collid) || '.' || strip(name)) pkg
, sum(case when pctSeq=1 then 1 else 0 end) pcT1
, sum(case when pctSeq=2 then 1 else 0 end) pcT2
, sum(case when useSeq=1 and lastUsed > current date - 3 year
then 1 else 0 end) use1
, sum(case when useSeq=2 and lastUsed > current date - 3 year
then 1 else 0 end) use2
, sum(case when valid = 'N' then 1 else 0 end) validNo
, sum(case when operative = 'N' then 1 else 0 end) operativeNo
from p
group by grouping sets((deact, dsr, reason), (deact), ())
having deact is null or reason is not null
or (reason is null and count(distinct reason) <> 1)
order by value(deact, ' '), value(substr(dsr, 2, 1), '')
with ur
;
}¢--- A540769.WK.SQL(PLANCLE0) cre=2016-11-07 mod=2016-11-13-11.36.48 A540769 ---
//A540769Z 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 s DP4G'
//SYSPROC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//OUT DD SYSOUT=*,DCB=(LRECL=32755,BLKSIZE=32760,RECFM=VB)
//WSH DD *
$*( *******************************************************************
planCle0: count rows from planTable to delete or to keep
use: change dbSys above; sub
plan table / explain table cleanup
planCle0 sql to select/count explains to delete
planCle1 alter clustering, reorg plantable
planCle2 delete rows from plantable
planCle3 delete rows from all other explain tables
******************************************************************* $*)
set current application compatibility 'V11R1';
with p2 as
(
select p.*
, case when timestamp > current timestamp - 15 days
then 1 else 0 end timNew
, case when lastUsed > current date - 3 years
then 1 else 0 end useLaY
from sysibm.sysPackage p
)
, p3 as
(
select collid, name, version, timestamp, lastUsed, timNew, useLaY
, sum(useLaY) over(partition by collid, name, timNew) useLaC
, dense_rank() over(partition by collid, name, timNew
order by lastUsed desc) useRn
, dense_rank() over(partition by collid, name, timNew
order by date(timestamp) desc) timRn
, dense_rank() over(partition by collid, name, timNew
order by date(pcTimestamp) desc) pctRn
, max(lastUsed) over (partition by collid, Name, timNew
order by lastUsed asc
rows between 1 following
and 1 following) useNext
from p2
)
, p as
(
select p3.*
, case when lastUsed > '01.01.1900' and useNext is not null
then lastUsed else '31.12.2999' end until
from p3
where timNew = 1 or useLaY = 1
or useLaC + useRn <= 2 and lastUsed > '01.01.1900'
or useLaC + timRn <= 2
or useLaC + pctRn <= 2
)
, e2 as
(
select collid, progName, version, explain_Time
, count(*) eCnt
, sum(case when optHint <> '' then 1
when hint_Used = '' or hint_Used = 'APREUSE' then 0
else 1 end) eHint
, case when explain_time > current timestamp - 15 days
then 1 else 0 end eNew
from cmnbatch.plan_table
group by collid, progName, version, explain_Time
)
, e as
(
select e2.*
, row_number() over (partition by collid, progName, version, eNew
order by explain_time desc) eRng
, max(explain_time)
over (partition by collid, progName, version, eNew
order by explain_time asc
rows between 1 following and 1 following) expNext
, 10 win
from e2
)
, f as
(
select e.collid, e.progName, e.version
, case when eNew = 1 then 'knew'
when eHint > 0 then 'khint'
when p.Name is null then 'rnoPk'
when explain_time < timestamp then 'rexp<pkg'
when date(e.explain_time) >= until then 'rafter'
when value(date(expNext), until) >= date(explain_time)
+ win days then 'kuse>' || win
when eRng <= 2 then 'keRng<=2'
when days(value(date(expNext), until)) / 90
<> days(explain_time) / 90 then 'kShort90'
else 'rtooShort' end ty
, p.timestamp, p.lastUsed, p.timRn, p.useNext, p.until
, e.explain_Time, eCnt
from e
left join p
on p.collid = e.collid and p.name = e.progName
and p.version = e.version
)
, g as
(
select f.*, left(ty, 1) kr
from f
)
select count(*) "#cpv", sum(eCnt) eCnt, kr, ty
from g
group by rollup(kr, ty)
order by ty desc
with ur
$*(
select *
from f
where collid = 'MF'
order by collid, progName, version, explain_time desc
fetch first 1000 rows only
$*)
}¢--- A540769.WK.SQL(PLANCLE1) cre=2016-11-10 mod=2016-11-13-10.14.57 A540769 ---
//A540769R JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,CLASS=M1,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2ALL
//*********************************************************************
//*
//* planCle1: alter cluster on plan_table and reorg
//* use: chg all DP4G db2SubSystem; sub
//*
//* plan table / explain table cleanup
//* planCle0 sql to select/count explains to delete
//* planCle1 alter clustering, reorg plantable
//* planCle2 delete rows from plantable
//* planCle3 delete rows from all other explain tables
//*********************************************************************
//ALTER EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DP4G)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=* DSN=A540769.TMP.TEXV(GRENZE)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
alter index cmnbatch.PLAN_TABLE_IDX1 not cluster;
alter index cmnbatch.PLAN_TABLE_PROG_IX cluster;
CREATE INDEX cmnBatch.DSN_FUNCTION_Table_idx1
ON cmnBatch.DSN_FUNCTION_Table
( "QUERYNO"
,"EXPLAIN_TIME"
)
USING STOGROUP GSMS PRIQTY -1 SECQTY -1 ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
NOT PADDED
DEFER YES
COMPRESS NO
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
CLUSTER
;
CREATE INDEX cmnbatch.DSN_STAT_FEEDBACK_idx1
ON cmnbatch.DSN_STAT_FEEDBACK
( "QUERYNO"
,"EXPLAIN_TIME"
)
USING STOGROUP GSMS PRIQTY -1 SECQTY -1 ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
NOT PADDED
DEFER YES
COMPRESS NO
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
CLUSTER
;
// IF ALTER.RUN AND (ALTER.RC = 0 OR ALTER.RC = 4) THEN
//REO EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769R.REORG'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=DP4G.DBAA.LISTDEF(TEMPL)
//UTPRINT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//STPRIN01 DD SYSOUT=*
//INDUMMY DD DUMMY
//SYSIN DD *
-- OPTIONS PREVIEW
LISTDEF TPLIST
INCLUDE TABLE CMNBATCH.PLAN_TABLE PARTLEVEL
INCLUDE TABLE CMNBATCH.DSN_FUNCTION_TABLE PARTLEVEL
INCLUDE TABLE CMNBATCH.DSN_STAT_FEEDBACK
---- reorg -------------------------------------------------------------
REORG TABLESPACE LIST TPLIST
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
DRAIN_WAIT 20
RETRY 20
RETRY_DELAY 180
MAXRO 20
DRAIN ALL
LONGLOG CONTINUE
DELAY 600
TIMEOUT TERM
UNLDDN TSRECD
UNLOAD CONTINUE
PUNCHDDN TPUNCH
DISCARDDN TDISC
SORTKEYS
SORTDEVT DISK
STATISTICS
INDEX ALL KEYCARD
UPDATE ALL
// ENDIF
}¢--- A540769.WK.SQL(PLANCLE2) cre=2016-11-09 mod=2016-11-10-11.16.29 A540769 ---
//A540769V JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99, 00020001
// PARM='WSH'
//SYSPROC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//OUT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$#@
$= dbSys=DP4G
$*( *******************************************************************
planCle2: delete rows from planTable, that are no longer needed
use: change dbSys above; sub
plan table / explain table cleanup
planCle0 sql to select/count explains to delete
planCle1 alter clustering, reorg plantable
planCle2 delete rows from plantable
planCle3 delete rows from all other explain tables
******************************************************************* $*)
$=tb=CMNBATCH.Plan_Table
comAft = 1000
comNxt = 0
cCom = 0
cDel = 0
cRow = 0
sleepAft = 20
call sqlConnect $dbSys
$= qx = 55
$= dx = 6
dx = $dx
$@queryExplain
$@comPre
$do fx=1 while sqlFetch($qx, i) $@¢
say fx m.i.ty m.i.collid m.i.prog m.i.version m.i.expTi m.i.eCnt
if m.i.kr == 'r' then $@¢
call sqlUpdateExecute dx, m.i.collid, m.i.prog, m.i.version,
, m.i.expTi
say 'deleted' m.sql.dx.updatecount
cDel = cDel + 1
comNxt = comNxt + m.sql.dx.updateCount
if comNxt >= comAft then $@¢
call sqlUpdate , rollback; say 'rollback abend for test'
$@comPre
cCom = cCom + 1
cRow = cRow + comNxt
comNxt = 0
say time() cCom 'commits,' cDel 'dels,' ,
cRow 'rows deleted' m.i.collid m.i.prog m.i.version
if cCom // sleepAft = 0 then
call sleep 10
$!
$!
$!
say time() cCom+1 'commits,' cDel 'dels,' ,
cRow+comNxt 'rows deleted'
$@comPre
$@ call sqlClose $qx
$proc $@/comPre/
call sqlCommit
call sqlUpdatePrepare $dx, 'delete from' $tb ,
'where collid = ? and progName = ? and version = ?' ,
'and explain_time = ?'
say 'commit prepare'
$/comPre/
$proc $@/queryExplain/
call sqlQuery $qx, scanSqlIn2Stmt()
$<=¢
$*( *******************************************************************
plan table / explain talbe cleanug
planCle0 sql to select/count explains to delete
planCle1 alter clustering, reorg plantable
planCle2 delete rows from plantable
planCle3 delete rows from all other explain tables
******************************************************************* $*)
with p2 as
(
select p.*
, case when timestamp > current timestamp - 15 days
then 1 else 0 end timNew
, case when lastUsed > current date - 3 years
then 1 else 0 end useLaY
from sysibm.sysPackage p
)
, p3 as
(
select collid, name, version, timestamp, lastUsed, timNew, useLaY
, sum(useLaY) over(partition by collid, name, timNew) useLaC
, dense_rank() over(partition by collid, name, timNew
order by lastUsed desc) useRn
, dense_rank() over(partition by collid, name, timNew
order by date(timestamp) desc) timRn
, dense_rank() over(partition by collid, name, timNew
order by date(pcTimestamp) desc) pctRn
, max(lastUsed) over (partition by collid, Name, timNew
order by lastUsed asc
rows between 1 following
and 1 following) useNext
from p2
)
, p as
(
select p3.*
, case when lastUsed > '01.01.1900' and useNext is not null
then lastUsed else '31.12.2999' end until
from p3
where timNew = 1 or useLaY = 1
or useLaC + useRn <= 2 and lastUsed > '01.01.1900'
or useLaC + timRn <= 2
or useLaC + pctRn <= 2
)
, e2 as
(
select collid, progName, version, explain_Time
, count(*) eCnt
, sum(case when optHint <> '' then 1
when hint_Used = '' or hint_Used = 'APREUSE' then 0
else 1 end) eHint
, case when explain_time > current timestamp - 15 days
then 1 else 0 end eNew
from cmnbatch.plan_table
group by collid, progName, version, explain_Time
)
, e as
(
select e2.*
, row_number() over (partition by collid, progName, version, eNew
order by explain_time desc) eRng
, max(explain_time)
over (partition by collid, progName, version, eNew
order by explain_time asc
rows between 1 following and 1 following) expNext
, 10 win
from e2
)
, f as
(
select e.collid, e.progName, e.version
, case when eNew = 1 then 'knew'
when eHint > 0 then 'khint'
when p.Name is null then 'rnoPk'
when explain_time < timestamp then 'rexp<pkg'
when date(e.explain_time) >= until then 'rafter'
when value(date(expNext), until) >= date(explain_time)
+ win days then 'kuse>' || win
when eRng <= 2 then 'keRng<=2'
when days(value(date(expNext), until)) / 90
<> days(explain_time) / 90 then 'kShort90'
else 'rtooShort' end ty
, p.timestamp, p.lastUsed, p.timRn, p.useNext, p.until
, e.explain_Time, eCnt
from e
left join p
on p.collid = e.collid and p.name = e.progName
and p.version = e.version
)
, g as
(
select f.*, left(ty, 1) kr
from f
)
select collid, progName prog, version, explain_time expTi, kr, ty, eCnt
from g
order by progName, collid, version desc, explain_time desc
$!
$/queryExplain/
$#out
}¢--- A540769.WK.SQL(PLANCLE3) cre=2016-11-10 mod=2016-11-14-07.33.38 A540769 ---
//A540769V JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
//*
//S1 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99, 00020001
// PARM='WSH'
//SYSPROC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//ABNLIGNR DD DUMMY SUPPRESS ABENDAID DUMPS
//OUT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$#@
$= dbSys=DE0G
$*( *******************************************************************
planCle3: delete rows from explain tables (dsn_),
that have no corresponing rows in plan_table
use: change dbSys above; sub
plan table / explain table cleanup
planCle0 sql to select/count explains to delete
planCle1 alter clustering, reorg plantable
planCle2 delete rows from plan_table
planCle3 delete rows from all other explain tables
******************************************************************* $*)
$=cr=CMNBATCH
comAftR = 500 $** commit after so many delete
comAftK = 1e5 $** commit after so many keep
sleepAft = 50
call sqlConnect $dbSys
cTb = 0
$<>
$<.^queryTables
$forWith $@/oneTb/
cTb = cTb + 1
say time() 'tableBegin' cTb $CR'.'$TB
if cTb <= 3 then iterate
cCom = 0
cR = 0
cRRw = 0
cK = 0
cKRw = 0
call sqlQuery 55, "select queryNo, explain_time, count(*) cnt",
" , case when exists (select 1 from" $cr".plan_Table t" ,
"where t.queryNo = d.queryNo" ,
"and t.explain_time = d.explain_time)",
" then 'k' else 'r' end kr" ,
"from" $CR'.'$TB d "group by queryNo, explain_Time" ,
"order by queryNo, explain_Time desc"
say time() 'tableQuery' cTb $CR'.'$TB
$@comPre
cRNx = cRRw + comAftR
cKNx = cKRw + comAftK
$do while sqlFetch(55, i) $@/oneFetch/
$** say m.i.kr m.i.queryNo m.i.explain_time m.i.cnt
if m.i.kr == 'k' then $@¢
cK = cK + 1
cKRw = cKRw + m.i.cnt
$! else $@¢
cR = cR + 1
cRRw = cRRw + m.i.cnt
call sqlUpdateExecute 7, m.i.queryNo, m.i.explain_time
if m.i.cnt <> m.sql.7.updateCount then
call err 'mismatch cnt='m.i.cnt ,
'<> updateCount='m.sql.7.updateCount
$!
if cRRw >= cRNx | cKRw >= cKNx then $@¢
cCom = cCom + 1
cRNx = cRRw + comAftR
cKNx = cKRw + comAftK
$@comPre
say time() cCom 'commits, deleted' cRRw '#t='cR',',
'kept' cKRw '#t='cK
if cCom // sleepAft = 0 then
call sleep 3
$!
$/oneFetch/
cCom = cCom + 1
$@comPre
say time() 'tableEnd' cTb $CR'.'$TB ,
cCom 'commits, deleted' cRRw '#t='cR',',
'kept' cKRw '#t='cK
call sqlClose 55
$/oneTb/
call sqlDisconnect
$proc $@/comPre/
call sqlCommit
call sqlUpdatePrepare 7, 'delete from' $CR'.'$TB ,
'where queryNo = ? and explain_time = ?'
$/comPre/
$proc $@/queryTables/
return in2Buf(sqlRdr( ,
"select creator cr, name tb from sysibm.sysTables" ,
"where creator = '"$cr"' and type = 'T'" ,
"and name like 'DSN%TABLE%' and right(strip(name),6)='_TABLE'",
"and not (name like '%QUERY_TABLE%'" ,
"or name like '%TEMENT_CACH%' or name like '%VIRTUAL_INDE%')",
"order by creator, name"))
$/queryTables/
$#out 20120208 13:45:49
}¢--- A540769.WK.SQL(PLANCLE4) cre=2016-11-13 mod=2016-11-14-07.18.27 A540769 ---
//A540769R JOB (CP00,KE50),'DB2 reo',
// TIME=1440,REGION=0M,SCHENV=DB2ALL,CLASS=M1,
// MSGCLASS=T,NOTIFY=&SYSUID
//*
//* ux utility generator reo
//* who RZX DE0G A540769 2
//* 13.11.16 16:11:03 A540769J
//*
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DE0G,'A540769R.REORG'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//*YSPRINT DD DSN=DSN.JOBRUN.A540769J.STEP1.#DT#,
//* DISP=(NEW,CATLG,CATLG),MGMTCLAS=BAT#NW,DSNTYPE=LARGE,
//* DCB=(RECFM=FB,LRECL=132,DSORG=PS),SPACE=(CYL,(1,1000))
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=DE0G.DBAA.LISTDEF(TEMPL)
//UTPRINT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//STPRIN01 DD SYSOUT=*
//INDUMMY DD DUMMY
//SYSIN DD *
--OPTIONS PREVIEW
LISTDEF ALLLI
INCLUDE TABLE CMNBATCH.PLAN_TABLE PARTLEVEL ALL
INCLUDE TABLE CMNBATCH.DSN_*_TABLE PARTLEVEL ALL
LISTDEF BASELI INCLUDE LIST ALLLI BASE
LISTDEF AUXLI INCLUDE LIST ALLLI LOB
INCLUDE LIST ALLLI XML
---- reorg base --------------------------------------------------------
REORG TABLESPACE LIST BASELI
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
DRAIN_WAIT 20
RETRY 20
RETRY_DELAY 180
MAXRO 20
DRAIN ALL
LONGLOG CONTINUE
DELAY 600
TIMEOUT TERM
UNLDDN TSRECD
UNLOAD CONTINUE
PUNCHDDN TPUNCH
DISCARDDN TDISC
SORTKEYS
SORTDEVT DISK
STATISTICS
INDEX ALL KEYCARD
UPDATE ALL
---- reorg lob and xml ----------------------------------------------
REORG TABLESPACE LIST AUXLI
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
DRAIN_WAIT 20
RETRY 20
RETRY_DELAY 180
MAXRO 20
DRAIN ALL
LONGLOG CONTINUE
DELAY 600
TIMEOUT TERM
UNLDDN TSRECD
UNLOAD CONTINUE
SORTKEYS
SORTDEVT DISK
---- runstats all ------------------------------------------------------
RUNSTATS TABLESPACE LIST ALLLI
SHRLEVEL CHANGE
TABLE USE PROFILE
TABLESAMPLE SYSTEM AUTO
}¢--- A540769.WK.SQL(PLANCLE7) cre=2016-11-10 mod=2016-11-10-10.13.42 A540769 ---
//A540769R JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,CLASS=M1,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2ALL
//ALTER EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DE0G)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=* DSN=A540769.TMP.TEXV(GRENZE)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
alter index cmnbatch.PLAN_TABLE_IDX1 not cluster;
alter index cmnbatch.PLAN_TABLE_PROG_IX cluster;
// IF ALTER.RUN AND ALTER.RC = 0 THEN
//REO EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DE0G,'A540769R.REORG'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//*YSPRINT DD DSN=DSN.JOBRUN.A540769V.STEP1.#DT#,
//* DISP=(NEW,CATLG,CATLG),MGMTCLAS=BAT#NW,DSNTYPE=LARGE,
//* DCB=(RECFM=FB,LRECL=132,DSORG=PS),SPACE=(CYL,(1,1000))
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=DE0G.DBAA.LISTDEF(TEMPL)
//UTPRINT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//STPRIN01 DD SYSOUT=*
//INDUMMY DD DUMMY
//SYSIN DD *
-- OPTIONS PREVIEW
LISTDEF TPLIST
INCLUDE TABLE CMNBATCH.PLAN_TABLE PARTLEVEL
---- reorg -------------------------------------------------------------
REORG TABLESPACE LIST TPLIST
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
DRAIN_WAIT 20
RETRY 20
RETRY_DELAY 180
MAXRO 20
DRAIN ALL
LONGLOG CONTINUE
DELAY 600
TIMEOUT TERM
UNLDDN TSRECD
UNLOAD CONTINUE
PUNCHDDN TPUNCH
DISCARDDN TDISC
SORTKEYS
SORTDEVT DISK
STATISTICS
INDEX ALL KEYCARD
UPDATE ALL
// ENDIF
}¢--- A540769.WK.SQL(PLANHIRE) cre=2016-11-07 mod=2016-11-07-20.51.08 A540769 ---
set current application compatibility 'V11R1';
select count(*), hint_used, remarks
from cmnBatch.plan_table
group by rollup(hint_used, remarks)
with ur
}¢--- A540769.WK.SQL(PLANQUER) cre=2011-05-13 mod=2016-11-03-09.23.23 A540769 ---
$#@
call sqlConnect dbtf
call sqlPrepare 1,
,'select explain_time, queryNo, type, query_Stage, seqNo,',
'length(node_data), node_data',
'from A540769.dsn_query_table' ,
'order by explain_time, queryNo, type, query_Stage, seqNo'
/* "where queryno = 110" ,
"and explain_time ='2010-03-15-16.03.26.767284'" */
call sqlOpen 1
$=o1 = $''
do cn=1 while sqlFetchInto(1, ':et, :qNo, :ty, :qs, :sq, :le, :no')
$@grChg-{et qNo, ty qs ,sq}
$*( $$- cn ml 'le' le if(le=length(no), '=', '<>') $*+
'length' length(no)':'left(no,50)
$$- ' 1='substr(no, 1, 70)
$$- ' 51='substr(no, 51, 70)
$$- '101='substr(no,101, 70)
$$- '151='substr(no,151, 70)
$$- '201='substr(no,201, 70)
$$- '251='substr(no,251, 70)
$*) cx = 0
wm = 60
do while cx < length(no)
we = min(cx+wm, length(no))
w2 = lastPos('<', no, we)
if w2 > cx+10 then
w2 = w2 - 1
else
w2 = we
$$- ' ' substr(no, cx+1, w2-cx)
cx = w2
end
end
$@grChg{}
call sqlDisconnect
$@proc grChg $@¢
parse arg , et qNo, ty qs, sq
say 'grpChg et qNo' $o1 '=>' et qNo ty qs 'seq' sq
if $o1 \== '' then $@¢
if $o1 \== et qNo | $o2 \== ty qs then
$$- ' </qGr2>'
if $o1 \== et qNo then
$$- '</qGr1>'
if et == '' then
$$- "</qGr>"
$!
if et \== '' then $@¢
if sq \== 1 then
call err 'implement sq' sq
if $o1 \== et qNo then $@¢
if $o1 == '' then
$$- "<qGr>"
$$- "<qGr1 et='"et"' qno='"qNo"'>"
$=o1 =- et qNo
$=o2 =- ''
$!
if $o2 \== ty qs then $@¢
$$- " <qGr2 ty='"ty"' qs='"qs"'>"
$=o2 =- ty qs
$!
$!
$!
$#out 20110514 00:09:55
<qGr>
<qGr1 et='2011-05-13-22.13.44.390000' qno='300'>
<qGr2 ty='SELECT' qs=' AFTER '>
<QUERY><SUBQUERY QBNO='1' PRUNED='N'>(<SEL-CLAUSE>SELECT
<SEL-LIST STAR='N'><LIST-ITEM TYPE='COLM'>
}¢--- A540769.WK.SQL(PLANTB) cre=2015-02-02 mod=2016-11-14-08.14.18 A540769 ----
$#: $*(******** create plan tables and views db2v11 ********** 10. 7.16
1) Parameter eingeben
2) wsh
3) job kontrollieren und sub
braucht update und drop/create auf plan_table|
v11 plan_table 66 Kolonnen bis expansion_reason
v10 plan_table 64 Kolonnen und Unicode
v9 plan_table 59 Kolonnen
v8 plan_table 58 Kolonnen
*********************** v7 plan_table 51 Kolonnen ******************$*)
dbSys = DP4G $** db2 subsystem
cr = A540769 $** creator
fun = v $*( funktion
c= create plan tables and views
u=update tables for v10 or v11 and recreate views
must already be UniCode ||||
r=drop Tablespaces and recreate everything
d=drop Tablespaces only
v=drop/recreate views only
vfD=drop all views using functions
vfC=create all views using functions $*)
job = Y4PLANTB $** jobName
vers = 11
queryT = 0 $** 1: mit userQuery tb, 0: ohne
queryV = 0 $** 1: mit VirtualIndexes und dynStmtCache, 0: ohne
f2P = 1 $** 1: FileAid f2Plan table
ul = $'' $** creator for unload before r and reload after r
stoGr = GSMS
db = DB2PLAN
schenv = SCHENV=DB2ALL,
$@ if $fun \== 'c' then $@¢ call sqlConnect $dbSys $!
$<>
$>. fEdit()
$@% work $cr
$*( *** history *******************************************************
Idee: ddl generator parallel zu DSNTESC (mit wsh markup)
übersichtlicher bei neuen Releaseen, Migration etc.
13.11.16 add indexes and cluster
10. 7.16 sort info und accesstype angepasst
9. 3.16 cmnViews deaktiviert
9. 2.16 vfD und vfC funktion fuer Funktionen drop/recreate
5. 2.15 mit PBG und db2 v11 oder v10 tables
6.11.14 neue Version F2Plan_table für FileAid mit fun=u
6. 6.14 achtung bind_time --> explain_time
29. 3.12 neu fun=d: drop Only, r= drop and recreate
21. 3.12 drop only necessary TS and Views ==> JobCondCode <=4
21. 3.12 create v10 views or migrate to v10
3. 2.12 allow v10 views (but do not change v9 to v10 yet|)
****************************************************************** $*)
$proc $@/work/
parse arg , cr
$= cr =- cr
$= cmnViews = 0 $** $cr = 'CMNBATCH' & sysvar(sysnode) == 'RZ2'
$= ts=- strip(left($cr, 7))
$= defer =- if($fun == 'u', 'YES', 'NO')
c7 = substr($ts, 7, 1)
if dataType(c7, 'n') then $@¢
$= tl =- left($ts, 6)substr('ABCDEFGHIJ', 1 + c7, 1)
$= tm =- left($ts, 6)substr('KLMNOPQRST', 1 + c7, 1)
$! else if c7 = ' ' then $@¢
$= tl = ${ts}L
$= tm = ${ts}M
$! else $@¢
r7 = substr(m.ut_alfUC, pos(c7, ut_alfUC))
$= tl =- left($ts, 6)substr(r7, 2, 1)
$= tm =- left($ts, 6)substr(r7, 3, 1)
$!
$= doReo = 0
if $fun \== 'c' then $@¢
if $fun \== 'v' then $@¢
$@getDdlInfo
$@getCatInfo
if $fun == 'u' then $@¢
px = m.itb.plan_table
if symbol('m.itb.px.ts') == 'VAR' ,
& m.itb.px.ts \== ${ts}'A' then
$=ts = $tm
$!
$!
$!
$@jobHead
if $fun == 'r' & $ul <> '' then
$@% load 0
$@ddlStep
if $fun == 'vfD' then
$@viewFunDrop
else if $fun == 'vfC' then
$@viewFunCre
else $@¢
if $fun == 'd' | $fun == 'r' then
$@tsDrop
if $fun == 'u' | $fun = 'v' then
$@dropViews
if $fun == 'c' | $fun == 'r' then
$@creDdl
if $fun == 'u' then
$@updDdl
if $fun \== 'd' then $@¢
$@ddlPlus
$@creViews
$!
if $fun == 'r' & $ul <> '' then
$@% load 1
if $doReo then
$@tsReo
$!
$/work/
$proc $@/load/
parse arg , lFu
say 'load' lFu
if \ lFu then $@=¢
$= crF = $cr
$= crT = $ul
$= stp = UNLO
$! else $@=¢
$= crF = $ul
$= crT = $cr
$= stp = LOAD
// IF RC <= 4 THEN
$!
$@=¢
//$stp EXEC PGM=DSNUTILB,PARM='$dbSys,$job.UNLO'
//SYSMAP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSERR DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
$do tx=1 to m.iTb.0 $@=¢
$@ if m.itb.tx.tbTy <> 'T' then iterate
$@ if \ ( abbrev(m.itb.tx.tb, 'PLAN_') $*+
| abbrev(m.itb.tx.tb, 'DSN_') $*+
| abbrev(m.itb.tx.tb, 'F2PLAN_') ) then $@¢
say 'not un/loading' m.itb.tx.tb
iterate
$!
$@ if \ $queryT & wordPos(m.itb.tx.tb, m.tbsT) > 0 then $@¢
say 'not queryT not un/loading' m.itb.tx.tb
iterate
$!
$@ if \ $queryV & wordPos(m.itb.tx.tb, m.tbsV) > 0 then $@¢
say 'not queryV not un/loading' m.itb.tx.tb
iterate
$!
$@ if symbol('m.cols.tx.0') \== 'VAR' then $@¢
call sql2St 'select name col from sysibm.sysColumns' ,
"where tbCreator = '"$cr"' and tbName = '"m.iTb.tx.tb"'",
"and colType <> 'ROWID'",
"order by colNo", 'COLS.'tx
$!
EXEC SQL
DECLARE CUR$tx CURSOR FOR
SELECT
$do cx = 1 to m.cols.tx.0 $@¢
$$- ' ' copies(',', cx > 1) m.cols.tx.cx.col '--' cx
$!
FROM $crF.$-¢m.iTb.tx.tb$!
ENDEXEC
LOAD DATA INCURSOR CUR$tx LOG NO RESUME NO REPLACE
COPYDDN TCOPYS STATISTICS INDEX ALL KEYCARD
SORTDEVT DISK
WORKDDN(TSYUTS,TSOUTS)
IDENTITYOVERRIDE
INTO TABLE $crT.$-¢m.iTb.tx.tb$!
-- IGNOREFIELDS YES
$!
LISTDEF CLST INCLUDE TABLESPACE $db.* PARTLEVEL LOB
COPY LIST CLST COPYDDN TCOPYS
FULL YES SHRLEVEL CHANGE PARALLEL SCOPE PENDING
$!
if lFu then $@=¢
// ENDIF
// ENDIF
$! else $@=¢
// IF RC <= 4 THEN
$!
$/load/
$proc $@/jobHead/
$@=¢
//$job JOB (CP00,KE50),
// MSGCLASS=T,CLASS=M1,$schenv
// NOTIFY=&SYSUID,TIME=1440
//*
//* dbSys = $dbSys
//* tableSpaces = $db.$ts* und $tl* für LOBs
//* creator = $cr
//* for version = v$vers
//*
$!
if $fun == 'c' then $@=¢
//* create plan tables only
$! else if $fun == 'r' then $@=¢
//* drop recreate plan tables and views
$@¢ if $ul = '' then $@=¢
//* all data lost ||||||||||||||||||||||||||||||||||||
$! else $@=¢
//* unload before to $ul
//* all data lost in $ul.*
//* reload after from $ul
$! $!
$! else if $fun == 'd' then $@=¢
//* drop tablespaces, tables and views
//* all data lost ||||||||||||||||||||||||||||||||||||
$! else if $fun == 'u' then $@=¢
//* update plantables for v$vers and recreate views
$! else if $fun == 'v' then $@=¢
//* drop recreate plan views only
$! else if $fun == 'vfD' then $@=¢
//* drop function dependent views
$! else if $fun == 'vfC' then $@=¢
//* create function dependent views
$! else $@¢
call err 'bad fun='$fun
$! if $cmnViews then $@=¢
//* with changeman views
$!
$/jobHead/
$proc $@=/ddlStep/
//*
//* execute ddl: drop/alter/create
//DDL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
--#SET MAXERRORS 0
set current sqlid = 'S100447';
$/ddlStep/
$proc $@/tsDrop/
done = ''
$do tt=0 to 1 $@¢
$do ix=1 to m.iTb.0 $@¢
dbts = strip(m.iTb.ix.db)'.'strip(m.iTb.ix.ts)
if (m.iTb.ix.tbTy \== 'T') == tt & done.dbTs <> 1 then $@¢
$$- 'drop tablespace' dbTs '; commit;'
done.dbTs = 1
$!
$!
$!
$<>
$<=¢
select dbName, name from sysibm.sysTableSpace
where dbName = '$db' and nTables = 0
and (name like '${ts}%' or name like '${tl}%'
or name like '${tm}%')
order by translate(type, 'ZZ', 'OP'), name
$! call sqlSel
$| $forWith d $@=¢
drop tablespace $DBNAME.$NAME; commit;
$!
$/tsDrop/
$proc $@/tsReo/
$@=¢
// IF DDL.RC LE 4 THEN
//REO EXEC PGM=DSNUTILB,TIME=1440,
// PARM=($dbSys,'$job.REORG'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
$!
done.0 = 0
done.1 = 0
$do tt=0 to 1 $@¢
$do ix=1 to m.iTb.0 $@¢
dbts = strip(m.iTb.ix.db)'.'strip(m.iTb.ix.ts)
if (m.iTb.ix.tbTy \== 'T') == tt & done.dbTs <> 1 then $@¢
if \ done.tt then $@¢
done.tt = 1
$$- 'LISTDEF' if(tt==0, 'TS', 'LOB')'LST'
$!
$$- ' INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
done.dbTs = 1
$!
$!
$!
if done.0 then $@=¢
REORG TABLESPACE LIST TSLST
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
MAPPINGTABLE S100447.MAPTAB03
MAXRO 30
DRAIN ALL
DELAY 150
TIMEOUT TERM
UNLDDN TSRECO
UNLOAD CONTINUE
PUNCHDDN TPUNCHO
DISCARDDN TDISCA
SORTKEYS
SORTDEVT DISK
STATISTICS
INDEX ALL KEYCARD
REPORT NO UPDATE ALL
$!
if done.1 then $@=¢
REORG TABLESPACE LIST LOBLST
SHRLEVEL REFERENCE
COPYDDN(TCOPYD)
UNLOAD CONTINUE
$!
$$ // ENDIF
$/tsReo/
$proc $@/creDdl/
$@ddl
$/creDdl/
$proc $@/updDdl/
$@ddl
$|
$do while $ddlTy \== 'e' $@/ddlEachLine/
if $ddlTy == 's' then $@¢
cc = substr(strip($ddlC1), 3)
if word(cc, 1) \== 'CREATE' then
cc = substr(strip($ddlC2), 3) cc
if word(cc, 1) \== 'CREATE' | (pos('TABLESPACE', cc) = 0 ,
& pos('TABLE SPACE', cc) = 0) then
call err 'bad comment before create ts' $ddlTs':' cc
tn = word(cc, words(cc))
if symbol('m.iTb.tn') == 'VAR' then $@¢
$@ddlRead
$! else $@¢
$$- '-- tablespace for' tn
$do forever $@¢
$$ $ddlLi
if pos(';', $ddlLi) > 0 then
leave
if $-^ddlRead \== 'l' then
call err 'eof in create tablespace for' tn
$!
$!
$! else if $ddlTy == 't' then $@¢
if \ ${?ITB>$ddlTb} then
$@creDdlTb
else if $ddlW2 == 'TABLE' then
$@updDdlTb
else
$@ddlRead
$! else $@¢
$@ddlRead
$!
$/ddlEachLine/
$/updDdl/
$proc $@/creDdlTb/
$do forever $@¢
$$ $ddlLi
if pos($-^ddlRead, 'ste') > 0 then
return
$!
$/creDdlTb/
$proc $@/updDdlTb/
tx = ${ITB>$ddlTb}
cols = m.itb.tx.colCount
col = m.itb.tx.col
first = 1
if $-^ddlRead \== 'l' | word($ddlLi, 1) \== '(' then
call err 'bad first line after create tb' $ddlLi
cc = 1
doAdd = 0
$do while $-^ddlRead == 'l' $@¢
w1 = word($ddlLi, 1)
if abbrev(w1, ')') then $@¢
if doAdd == 2 then $@¢
$$ ;
$= doReo = 1
$! else if cc < cols then
call err 'table' $cr'.'m.iTb.tx.tb ,
'has only' cc 'columns not >=' cols
return
$! else if abbrev(w1, ',') | abbrev(w1, '"') then $@¢
cc = cc+ 1
if cc = cols then $@¢
nm = word(substr(strip($ddlLi), 1 + abbrev(w1,',')), 1)
if nm \== col & nm \== '"'col'"' then
call err 'col' cols 'should be' col 'not' nm ,
'in table' $cr'.'m.iTb.tx.tb
doAdd = 1
$! else if doAdd > 0 then $@¢
if doAdd == 1 then $@¢
doAdd = 2
$$ alter table $cr.$-¢m.iTb.tx.tb$!
$!
$$- ' add' strip(substr(strip($ddlLi), 2))
$!
$! else if doAdd == 2 then $@¢
$$ $ddlLi
$!
$!
$/updDdlTb/
$proc $@/getDdlInfo/
m.tbsT = 'DSN_PREDICATE_SELECTIVITY DSN_USERQUERY_TABLE' ,
'DSN_USERQUERY_TABLE_AUX'
m.tbsV = 'DSN_STATEMENT_CACHE_TABLE DSN_STATEMENT_CACHE_AUX' ,
'DSN_VIRTUAL_INDEXES DSN_VIRTUAL_KEYTARGETS'
tbs = m.tbsT m.tbsV 'COST_TABLE',
'EEEAUTH EEEDBRM EEEHINT EEEPATH EEEPLAN EEEWORK',
'OBJECT_DATA OBJECT_DIRECTORY F2PLAN_TABLE',
'PREDICATE_TABLE STRUCTURE_TABLE',
'DSN_STAT_FEEDBACK'
tbs = "'"repAll(space(tbs, 1), ' ', "', '")"'"
$@ddl
$|
$do while $-^ddlRead \== 'e' $@¢
if $ddlTy == 't' then
tbs = tbs", '"$ddlTb"'"
$!
m.itb.tbLst = tbs
$/getDdlInfo/
$proc $@/getCatInfo/
call sql2St 'select t.name tb, t.dbName db, tsName ts,t.Type tbTy' ,
', colCount, c.name col, s.nTables' ,
'from sysibm.sysTables t join sysibm.sysColumns c' ,
'on t.creator = c.tbCreator and t.name = c.tbName' ,
'and t.colCount = c.colNo',
'join sysibm.sysTableSpace s' ,
'on t.dbName = s.dbName and t.tsName = s.name',
"where t.creator = '"$cr"' and t.name in ("m.itb.tbLst")" ,
, iTb
do qx=1 to m.iTb.0
$*( say qx m.iTb.qx.tb m.iTb.qx.db m.iTb.qx.ts m.iTb.qx.tbTy ,
m.iTb.qx.colCount m.iTb.qx.col
$*) t1 = strip(m.iTb.qx.tb)
m.itb.t1 = qx
end
$/getCatInfo/
$proc $@/ddlRead/
if \ $-{>ddlLi} then $@¢
$=ddlTy = e
return $ddlTy
$!
parse value $ddlLi with w1 w2 w3 .
$= ddlW2 =- w2
if abbrev(w1, '--') then $@¢
$=ddlC2 = $ddlC1
$=ddlC1 = $ddlLi
$=ddlTy = l
$! else if w1 \== 'CREATE' then $@¢
$=ddlTy = l
$! else if w2 == 'TABLESPACE' then $@¢
$=ddlTy = s
$=ddlTs = w3
$! else if w2 == 'LOB' & w3 == 'TABLESPACE' then $@¢
$=ddlTy = s
$=ddlTs = word($ddlLi, 4)
$! else if w2 == 'TABLE' ,
| (w2 == 'AUX' & w3 == 'TABLE') then $@¢
if w2 == 'TABLE' then
parse value subWord($ddlLi, 3) with cr '.' tb .
else
parse value subWord($ddlLi, 4) with cr '.' tb .
if cr <> $cr then
call err 'creator should be' $cr 'but' $ddlLi
$=ddlTb =- strip(tb)
$=ddlTy = t
$! else $@¢
$=ddlTy = l
$!
return $ddlTy
$/ddlRead/
$@proc $@/ixKeys/
parse arg ., vKy vDr ix
if $fun == 'c' | $fun == 'r' then
$={$-¢vKy$!}=- ''
else
$={$-¢vKy$!}=- catIxKeys($cr, ix)
if ${$-¢vKy$!} == '' then
$={$-¢vDr$!}=- ''
else
$={$-¢vDr$!}=- 'drop index' $cr'.'ix';commit;'
$/ixKeys/
$proc $@=/tsAtt/
USING STOGROUP $stoGr
ERASE NO
GBPCACHE CHANGED
LOCKSIZE PAGE LOCKMAX SYSTEM
BUFFERPOOL BP8K0
SEGSIZE 16
CLOSE NO
maxpartitions 16
dsSize 4G
CCSID UNICODE
$/tsAtt/
$proc $@=/lobAtt/
BUFFERPOOL BP32K
LOG YES
GBPCACHE CHANGED
USING STOGROUP GSMS PRIQTY -1 SECQTY -1 ERASE NO
CLOSE YES
$/lobAtt/
$proc $@=/tbAtt/
AUDIT NONE
VOLATILE
DATA CAPTURE CHANGES
CCSID UNICODE
APPEND NO
$/tbAtt/
$proc $@=/ixAtt/
USING STOGROUP GSMS PRIQTY -1 SECQTY -1 ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
$@ if pos('l', arg(2)) < 1 then $@=¢ $** not allowed for lob
NOT PADDED
DEFER $defer
$!
COMPRESS NO
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
$@ if pos('c', arg(2)) >= 1 then
CLUSTER
$/ixAtt/
$proc $@=/creIxQE/
$@ parse arg , aTb ',' aOpt
CREATE INDEX $cr.$-¢strip(aTb)$!_idx1
ON $cr.$-¢aTb$!
( "QUERYNO"
,"EXPLAIN_TIME"
)
$@% ixAtt - aOpt
;
$/creIxQE/
$@proc $@/dropViews/
$<=¢ select (select strip(d.bcreator) || '.' || strip(d.bname)
from sysibm.sysViewDep d
where bType = 'V'
and d.dcreator = v.creator and dName = v.name
and d.bcreator = v.creator and bName like 'PLAN%'
fetch first row only
) dep, v.creator cr, v.name na
from sysibm.sysTables v
where type = 'V' and name like 'PLAN%'
and creator = '$cr'
$!
call sqlSel
$| $@forWith v $@¢
if $DEP == m.sqlNull then
$$ drop view $CR.$NA;
else
$$ $' --' view $CR.$NA depends on $DEP
$!
$/dropViews/
$proc $@/ddl/
$=ddlTy = $''
$= ddlC1 = $''
$= ddlC2 = $''
$@expDdl
if $queryT then
$@uQuDdl
$/ddl/
$proc $@=/expDdl/
-----------------------------------------------------------------------
-- NAME = DSNTESC aus SDSNSAMP(DSNTESC)
--
-- DESCRIPTIVE NAME = SAMPLE EXPLAIN TABLES
--
-- LICENSED MATERIALS - PROPERTY OF IBM
-- 5615-DB2
-- (C) COPYRIGHT 1982, 2013 IBM CORP. ALL RIGHTS RESERVED.
--
-- STATUS = VERSION 11
--
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE PLAN_TABLE
CREATE TABLESPACE ${ts}A
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_FUNCTION_TABLE
CREATE TABLESPACE ${ts}B
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_STATEMNT_TABLE
CREATE TABLESPACE ${ts}C
IN $db
$@tsAtt
;
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE
--DSN_STATEMENT_CACHE_TABLE
CREATE TABLESPACE ${ts}D
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE LOB TABLE SPACE FOR THE SAMPLE DSN_STATEMENT_CACHE_TABLE
CREATE LOB TABLESPACE ${tl}D
IN $db
$@lobAtt
;
$!
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_PREDICAT_TABLE
CREATE TABLESPACE ${ts}E
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_STRUCT_TABLE
CREATE TABLESPACE ${ts}F
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_PGROUP_TABLE
CREATE TABLESPACE ${ts}G
IN $db
$@%¢tsAtt bp16K0 $!
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_PTASK_TABLE
CREATE TABLESPACE ${ts}H
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_FILTER_TABLE
CREATE TABLESPACE ${ts}K
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_DETCOST_TABLE
CREATE TABLESPACE ${ts}L
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_SORT_TABLE
CREATE TABLESPACE ${ts}M
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_SORTKEY_TABLE
CREATE TABLESPACE ${ts}N
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_PGRANGE_TABLE
CREATE TABLESPACE ${ts}O
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_VIEWREF_TABLE
CREATE TABLESPACE ${ts}P
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_QUERY_TABLE
CREATE TABLESPACE ${ts}I
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE LOB TABLE SPACE FOR THE SAMPLE DSN_QUERY_TABLE
CREATE LOB TABLESPACE ${tl}I
IN $db
$@lobAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_QUERYINFO_TABLE
CREATE TABLESPACE ${ts}Q
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE LOB TABLE SPACE FOR THE SAMPLE DSN_QUERYINFO_TABLE
CREATE LOB TABLESPACE ${tl}Q
IN $db
$@lobAtt
;
-----------------------------------------------------------------------
--CREATE THE LOB TABLE SPACE FOR THE SAMPLE DSN_QUERYINFO_TABLE
CREATE LOB TABLESPACE ${tl}R
IN $db
$@lobAtt
;
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_VIRTUAL_INDEXES
CREATE TABLESPACE ${ts}J
IN $db
$@tsAtt
;
$!
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_COLDIST_TABLE
CREATE TABLESPACE ${ts}S
IN $db
$@tsAtt
;
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_KEYTGTDIST_TABLE
CREATE TABLESPACE ${ts}T
IN $db
$@tsAtt
;
$@ if $vers >= 11 then $@=¢
$@ if $queryT then $@=¢
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE
--DSN_PREDICATE_SELECTIVITY
CREATE TABLESPACE ${ts}U
IN $db
$@tsAtt
;
$!
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_STAT_FEEDBACK
CREATE TABLESPACE ${ts}W
IN $db
$@tsAtt
;
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACE FOR THE V11 SAMPLE DSN_VIRTUAL_KEYTARGETS
CREATE TABLESPACE ${ts}X
IN $db
$@tsAtt
;
$!
$!
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE PLAN_TABLE AND ITS INDEX
CREATE TABLE $cr.PLAN_TABLE
( "QUERYNO" INTEGER NOT NULL,
"QBLOCKNO" SMALLINT NOT NULL,
"APPLNAME" VARCHAR(24) NOT NULL,
"PROGNAME" VARCHAR(128) NOT NULL,
"PLANNO" SMALLINT NOT NULL,
"METHOD" SMALLINT NOT NULL,
"CREATOR" VARCHAR(128) NOT NULL,
"TNAME" VARCHAR(128) NOT NULL,
"TABNO" SMALLINT NOT NULL,
"ACCESSTYPE" CHAR(2) NOT NULL,
"MATCHCOLS" SMALLINT NOT NULL,
"ACCESSCREATOR" VARCHAR(128) NOT NULL,
"ACCESSNAME" VARCHAR(128) NOT NULL,
"INDEXONLY" CHAR(1) NOT NULL,
"SORTN_UNIQ" CHAR(1) NOT NULL,
"SORTN_JOIN" CHAR(1) NOT NULL,
"SORTN_ORDERBY" CHAR(1) NOT NULL,
"SORTN_GROUPBY" CHAR(1) NOT NULL,
"SORTC_UNIQ" CHAR(1) NOT NULL,
"SORTC_JOIN" CHAR(1) NOT NULL,
"SORTC_ORDERBY" CHAR(1) NOT NULL,
"SORTC_GROUPBY" CHAR(1) NOT NULL,
"TSLOCKMODE" CHAR(3) NOT NULL,
"TIMESTAMP" CHAR(16) NOT NULL,
"REMARKS" VARCHAR(762) NOT NULL,
"PREFETCH" CHAR(1) NOT NULL WITH DEFAULT,
"COLUMN_FN_EVAL" CHAR(1) NOT NULL WITH DEFAULT,
"MIXOPSEQ" SMALLINT NOT NULL WITH DEFAULT,
"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT,
"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT,
"ACCESS_DEGREE" SMALLINT,
"ACCESS_PGROUP_ID" SMALLINT,
"JOIN_DEGREE" SMALLINT,
"JOIN_PGROUP_ID" SMALLINT,
"SORTC_PGROUP_ID" SMALLINT,
"SORTN_PGROUP_ID" SMALLINT,
"PARALLELISM_MODE" CHAR(1),
"MERGE_JOIN_COLS" SMALLINT,
"CORRELATION_NAME" VARCHAR(128),
"PAGE_RANGE" CHAR(1) NOT NULL WITH DEFAULT,
"JOIN_TYPE" CHAR(1) NOT NULL WITH DEFAULT,
"GROUP_MEMBER" VARCHAR(24) NOT NULL WITH DEFAULT,
"IBM_SERVICE_DATA" VARCHAR(254) FOR BIT DATA
NOT NULL WITH DEFAULT,
"WHEN_OPTIMIZE" CHAR(1) NOT NULL WITH DEFAULT,
"QBLOCK_TYPE" CHAR(6) NOT NULL WITH DEFAULT,
"BIND_TIME" TIMESTAMP NOT NULL WITH DEFAULT,
"OPTHINT" VARCHAR(128) NOT NULL WITH DEFAULT,
"HINT_USED" VARCHAR(128) NOT NULL WITH DEFAULT,
"PRIMARY_ACCESSTYPE" CHAR(1) NOT NULL WITH DEFAULT,
"PARENT_QBLOCKNO" SMALLINT NOT NULL WITH DEFAULT,
"TABLE_TYPE" CHAR(1),
"TABLE_ENCODE" CHAR(1) NOT NULL WITH DEFAULT,
"TABLE_SCCSID" SMALLINT NOT NULL WITH DEFAULT,
"TABLE_MCCSID" SMALLINT NOT NULL WITH DEFAULT,
"TABLE_DCCSID" SMALLINT NOT NULL WITH DEFAULT,
"ROUTINE_ID" INTEGER NOT NULL WITH DEFAULT,
"CTEREF" SMALLINT NOT NULL WITH DEFAULT,
"STMTTOKEN" VARCHAR(240),
"PARENT_PLANNO" SMALLINT NOT NULL WITH DEFAULT,
"BIND_EXPLAIN_ONLY" CHAR(1) NOT NULL WITH DEFAULT,
"SECTNOI" INTEGER NOT NULL WITH DEFAULT,
"EXPLAIN_TIME" TIMESTAMP NOT NULL WITH DEFAULT,
"MERGC" CHAR(1) NOT NULL WITH DEFAULT,
"MERGN" CHAR(1) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
, "SCAN_DIRECTION" CHAR(1)
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}A
$@tbAtt;
CREATE INDEX $cr.PLAN_TABLE_HINT_IX
ON $cr.PLAN_TABLE
( "QUERYNO",
"APPLNAME",
"PROGNAME",
"VERSION",
"COLLID",
"OPTHINT" )
$@ixAtt
; $** rest of indexes further down >>>>>>>>>>>>>>>>>>>
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_FUNCTION_TABLE.
CREATE TABLE $cr.DSN_FUNCTION_TABLE
( "QUERYNO" INTEGER NOT NULL WITH DEFAULT,
"QBLOCKNO" INTEGER NOT NULL WITH DEFAULT,
"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT,
"PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT,
"GROUP_MEMBER" VARCHAR(24) NOT NULL WITH DEFAULT,
"EXPLAIN_TIME" TIMESTAMP NOT NULL WITH DEFAULT,
"SCHEMA_NAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"FUNCTION_NAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"SPEC_FUNC_NAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"FUNCTION_TYPE" CHAR(2) NOT NULL WITH DEFAULT,
"VIEW_CREATOR" VARCHAR(128) NOT NULL WITH DEFAULT,
"VIEW_NAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"PATH" VARCHAR(2048) NOT NULL WITH DEFAULT,
"FUNCTION_TEXT" VARCHAR(1500) NOT NULL WITH DEFAULT,
"FUNC_VERSION" VARCHAR(122) NOT NULL WITH DEFAULT,
"SECURE" CHAR(1) NOT NULL WITH DEFAULT,
"SECTNOI" INTEGER NOT NULL WITH DEFAULT,
"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}B
$@tbAtt;
$@% creIxQE DSN_FUNCTION_Table, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_STATEMNT_TABLE.
CREATE TABLE $cr.DSN_STATEMNT_TABLE
( "QUERYNO" INTEGER NOT NULL WITH DEFAULT,
"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT,
"PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT,
"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT,
"GROUP_MEMBER" VARCHAR(24) NOT NULL WITH DEFAULT,
"EXPLAIN_TIME" TIMESTAMP NOT NULL WITH DEFAULT,
"STMT_TYPE" CHAR(6) NOT NULL WITH DEFAULT,
"COST_CATEGORY" CHAR(1) NOT NULL WITH DEFAULT,
"PROCMS" INTEGER NOT NULL WITH DEFAULT,
"PROCSU" INTEGER NOT NULL WITH DEFAULT,
"REASON" VARCHAR(254) NOT NULL WITH DEFAULT,
"STMT_ENCODE" CHAR(1) NOT NULL WITH DEFAULT,
"TOTAL_COST" FLOAT NOT NULL WITH DEFAULT,
"SECTNOI" INTEGER NOT NULL WITH DEFAULT,
"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}C
$@tbAtt;
$@% creIxQE DSN_STATEMNT_TABLE, c
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_STATEMENT_CACHE_TABLE AND ITS INDEXES
CREATE TABLE $cr.DSN_STATEMENT_CACHE_TABLE
( "STMT_ID" INTEGER NOT NULL,
"STMT_TOKEN" VARCHAR(240) ,
"COLLID" VARCHAR(128) NOT NULL,
"PROGRAM_NAME" VARCHAR(128) NOT NULL,
"INV_DROPALT" CHAR(1) NOT NULL,
"INV_REVOKE" CHAR(1) NOT NULL,
"INV_LRU" CHAR(1) NOT NULL,
"INV_RUNSTATS" CHAR(1) NOT NULL,
"CACHED_TS" TIMESTAMP NOT NULL,
"USERS" INTEGER NOT NULL,
"COPIES" INTEGER NOT NULL,
"LINES" INTEGER NOT NULL,
"PRIMAUTH" VARCHAR(128) NOT NULL,
"CURSQLID" VARCHAR(128) NOT NULL,
"BIND_QUALIFIER" VARCHAR(128) NOT NULL,
"BIND_ISO" CHAR(2) NOT NULL,
"BIND_CDATA" CHAR(1) NOT NULL,
"BIND_DYNRL" CHAR(1) NOT NULL,
"BIND_DEGRE" CHAR(1) NOT NULL,
"BIND_SQLRL" CHAR(1) NOT NULL,
"BIND_CHOLD" CHAR(1) NOT NULL,
"STAT_TS" TIMESTAMP NOT NULL,
"STAT_EXEC" INTEGER NOT NULL,
"STAT_GPAG" INTEGER NOT NULL,
"STAT_SYNR" INTEGER NOT NULL,
"STAT_WRIT" INTEGER NOT NULL,
"STAT_EROW" INTEGER NOT NULL,
"STAT_PROW" INTEGER NOT NULL,
"STAT_SORT" INTEGER NOT NULL,
"STAT_INDX" INTEGER NOT NULL,
"STAT_RSCN" INTEGER NOT NULL,
"STAT_PGRP" INTEGER NOT NULL,
"STAT_ELAP" FLOAT NOT NULL,
"STAT_CPU" FLOAT NOT NULL,
"STAT_SUS_SYNIO" FLOAT NOT NULL,
"STAT_SUS_LOCK" FLOAT NOT NULL,
"STAT_SUS_SWIT" FLOAT NOT NULL,
"STAT_SUS_GLCK" FLOAT NOT NULL,
"STAT_SUS_OTHR" FLOAT NOT NULL,
"STAT_SUS_OTHW" FLOAT NOT NULL,
"STAT_RIDLIMT" INTEGER NOT NULL,
"STAT_RIDSTOR" INTEGER NOT NULL,
"EXPLAIN_TS" TIMESTAMP NOT NULL,
"SCHEMA" VARCHAR(128) NOT NULL,
"STMT_TEXT" CLOB(2M) NOT NULL,
"STMT_ROWID" ROWID NOT NULL GENERATED ALWAYS,
"BIND_RO_TYPE" CHAR(1) NOT NULL WITH DEFAULT,
"BIND_RA_TOT" INTEGER NOT NULL WITH DEFAULT,
"GROUP_MEMBER" VARCHAR(24) NOT NULL WITH DEFAULT,
"STAT_EXECB" BIGINT NOT NULL WITH DEFAULT,
"STAT_GPAGB" BIGINT NOT NULL WITH DEFAULT,
"STAT_SYNRB" BIGINT NOT NULL WITH DEFAULT,
"STAT_WRITB" BIGINT NOT NULL WITH DEFAULT,
"STAT_EROWB" BIGINT NOT NULL WITH DEFAULT,
"STAT_PROWB" BIGINT NOT NULL WITH DEFAULT,
"STAT_SORTB" BIGINT NOT NULL WITH DEFAULT,
"STAT_INDXB" BIGINT NOT NULL WITH DEFAULT,
"STAT_RSCNB" BIGINT NOT NULL WITH DEFAULT,
"STAT_PGRPB" BIGINT NOT NULL WITH DEFAULT,
"STAT_RIDLIMTB" BIGINT NOT NULL WITH DEFAULT,
"STAT_RIDSTORB" BIGINT NOT NULL WITH DEFAULT,
"LITERAL_REPL" CHAR(1) NOT NULL WITH DEFAULT,
"STAT_SUS_LATCH" FLOAT NOT NULL WITH DEFAULT,
"STAT_SUS_PLATCH" FLOAT NOT NULL WITH DEFAULT,
"STAT_SUS_DRAIN" FLOAT NOT NULL WITH DEFAULT,
"STAT_SUS_CLAIM" FLOAT NOT NULL WITH DEFAULT,
"STAT_SUS_LOG" FLOAT NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}D
$@tbAtt;
CREATE AUX TABLE $cr.DSN_STATEMENT_CACHE_AUX
IN $db.${tl}D
STORES $cr.DSN_STATEMENT_CACHE_TABLE
COLUMN STMT_TEXT
PART 1;
CREATE INDEX $cr.DSN_STATEMENT_CACHE_IDX1
ON $cr.DSN_STATEMENT_CACHE_TABLE
( "STMT_ID" ASC )
$@ixAtt
;
CREATE INDEX $cr.DSN_STATEMENT_CACHE_IDX2
ON $cr.DSN_STATEMENT_CACHE_TABLE
( "STMT_TOKEN" ASC )
$@% ixAtt c
;
CREATE INDEX $cr.DSN_STATEMENT_CACHE_IDX3
ON $cr.DSN_STATEMENT_CACHE_TABLE
( "EXPLAIN_TS" DESC )
$@ixAtt
;
CREATE INDEX $cr.DSN_STATEMENT_CACHE_AUXINX
ON $cr.DSN_STATEMENT_CACHE_AUX
$@%¢ixAtt l $!
;
$!
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_PREDICAT_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_PREDICAT_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"PREDNO" INTEGER NOT NULL
,"TYPE" CHAR(8) NOT NULL
,"LEFT_HAND_SIDE" VARCHAR(128) NOT NULL
,"LEFT_HAND_PNO" INTEGER NOT NULL
,"LHS_TABNO" SMALLINT NOT NULL
,"LHS_QBNO" SMALLINT NOT NULL
,"RIGHT_HAND_SIDE" VARCHAR(128) NOT NULL
,"RIGHT_HAND_PNO" INTEGER NOT NULL
,"RHS_TABNO" SMALLINT NOT NULL
,"RHS_QBNO" SMALLINT NOT NULL
,"FILTER_FACTOR" FLOAT NOT NULL
,"BOOLEAN_TERM" CHAR(1) NOT NULL
,"SEARCHARG" CHAR(1) NOT NULL
,"JOIN" CHAR(1) NOT NULL
,"AFTER_JOIN" CHAR(1) NOT NULL
,"ADDED_PRED" CHAR(1) NOT NULL
,"REDUNDANT_PRED" CHAR(1) NOT NULL
,"DIRECT_ACCESS" CHAR(1) NOT NULL
,"KEYFIELD" CHAR(1) NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"CATEGORY" SMALLINT NOT NULL
,"CATEGORY_B" SMALLINT NOT NULL
,"TEXT" VARCHAR(2000) NOT NULL
,"PRED_ENCODE" CHAR(1) NOT NULL WITH DEFAULT
,"PRED_CCSID" SMALLINT NOT NULL WITH DEFAULT
,"PRED_MCCSID" SMALLINT NOT NULL WITH DEFAULT
,"MARKER" CHAR(1) NOT NULL WITH DEFAULT
,"PARENT_PNO" INTEGER NOT NULL
,"NEGATION" CHAR(1) NOT NULL
,"LITERALS" VARCHAR(128) NOT NULL
,"CLAUSE" CHAR(8) NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"ORIGIN" CHAR(1) NOT NULL WITH DEFAULT
,"UNCERTAINTY" FLOAT(4) NOT NULL WITH DEFAULT
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}E
$@tbAtt;
$@% creIxQE DSN_PREDICAT_TABLE, c
CREATE INDEX $cr.DSN_PREDICAT_TABLE_IDX2
ON $cr.DSN_PREDICAT_TABLE
( "QUERYNO"
, "PREDNO"
)
$@ixAtt
;
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_STRUCT_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_STRUCT_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"PARENT" SMALLINT NOT NULL
,"TIMES" FLOAT NOT NULL
,"ROWCOUNT" INTEGER NOT NULL
,"ATOPEN" CHAR(1) NOT NULL
,"CONTEXT" CHAR(10) NOT NULL
,"ORDERNO" SMALLINT NOT NULL
,"DOATOPEN_PARENT" SMALLINT NOT NULL
,"QBLOCK_TYPE" CHAR(6) NOT NULL WITH DEFAULT
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"QUERY_STAGE" CHAR(8) NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"ORIGIN" CHAR(1) NOT NULL WITH DEFAULT
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}F
$@tbAtt;
$@% creIxQE DSN_STRUCT_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_PGROUP_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_PGROUP_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"PLANNAME" VARCHAR(24) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"VERSION" VARCHAR(122) NOT NULL
,"GROUPID" SMALLINT NOT NULL
,"FIRSTPLAN" SMALLINT NOT NULL
,"LASTPLAN" SMALLINT NOT NULL
,"CPUCOST" REAL NOT NULL
,"IOCOST" REAL NOT NULL
,"BESTTIME" REAL NOT NULL
,"DEGREE" SMALLINT NOT NULL
,"MODE" CHAR(1) NOT NULL
,"REASON" SMALLINT NOT NULL
,"LOCALCPU" SMALLINT NOT NULL
,"TOTALCPU" SMALLINT NOT NULL
,"FIRSTBASE" SMALLINT
,"LARGETS" CHAR(1)
,"PARTKIND" CHAR(1)
,"GROUPTYPE" CHAR(3)
,"ORDER" CHAR(1)
,"STYLE" CHAR(4)
,"RANGEKIND" CHAR(1)
,"NKEYCOLS" SMALLINT
,"LOWBOUND" VARCHAR(40) FOR BIT DATA
,"HIGHBOUND" VARCHAR(40) FOR BIT DATA
,"LOWKEY" VARCHAR(40) FOR BIT DATA
,"HIGHKEY" VARCHAR(40) FOR BIT DATA
,"FIRSTPAGE" CHAR(4) FOR BIT DATA
,"LASTPAGE" CHAR(4) FOR BIT DATA
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"HOST_REASON" SMALLINT
,"PARA_TYPE" CHAR(4)
,"PART_INNER" CHAR(1)
,"GRNU_KEYRNG" CHAR(1)
,"OPEN_KEYRNG" CHAR(1)
,"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"STRAW_MODEL" CHAR(1) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}G
$@tbAtt;
$@% creIxQE DSN_PGROUP_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_PTASK_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_PTASK_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"PGDNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"LPTNO" SMALLINT NOT NULL
,"KEYCOLID" SMALLINT
,"DPSI" CHAR(1) NOT NULL
,"LPTLOKEY" VARCHAR(40) FOR BIT DATA
,"LPTHIKEY" VARCHAR(40) FOR BIT DATA
,"LPTLOPAG" CHAR(4) FOR BIT DATA
,"LPTHIPAG" CHAR(4) FOR BIT DATA
,"LPTLOPG" CHAR(4) FOR BIT DATA
,"LPTHIPG" CHAR(4) FOR BIT DATA
,"LPTLOPT" SMALLINT
,"LPTHIPT" SMALLINT
,"KEYCOLDT" SMALLINT
,"KEYCOLPREC" SMALLINT
,"KEYCOLSCAL" SMALLINT
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}H
$@tbAtt;
$@% creIxQE DSN_PTASK_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_FILTER_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_FILTER_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"PLANNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"ORDERNO" INTEGER NOT NULL
,"PREDNO" INTEGER NOT NULL
,"STAGE" CHAR(9) NOT NULL
,"ORDERCLASS" INTEGER NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"MIXOPSEQNO" SMALLINT NOT NULL
,"REEVAL" CHAR(1) NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
,"PUSHDOWN" CHAR(1) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}K
$@tbAtt;
$@% creIxQE DSN_FILTER_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_DETCOST_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_DETCOST_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"PLANNO" SMALLINT NOT NULL
,"OPENIO" FLOAT(4) NOT NULL
,"OPENCPU" FLOAT(4) NOT NULL
,"OPENCOST" FLOAT(4) NOT NULL
,"DMIO" FLOAT(4) NOT NULL
,"DMCPU" FLOAT(4) NOT NULL
,"DMTOT" FLOAT(4) NOT NULL
,"SUBQIO" FLOAT(4) NOT NULL
,"SUBQCPU" FLOAT(4) NOT NULL
,"SUBQCOST" FLOAT(4) NOT NULL
,"BASEIO" FLOAT(4) NOT NULL
,"BASECPU" FLOAT(4) NOT NULL
,"BASETOT" FLOAT(4) NOT NULL
,"ONECOMPROWS" FLOAT(4) NOT NULL
,"IMLEAF" FLOAT(4) NOT NULL
,"IMIO" FLOAT(4) NOT NULL
,"IMPREFH" CHAR(2) NOT NULL
,"IMMPRED" INTEGER NOT NULL
,"IMFF" FLOAT(4) NOT NULL
,"IMSRPRED" INTEGER NOT NULL
,"IMFFADJ" FLOAT(4) NOT NULL
,"IMSCANCST" FLOAT(4) NOT NULL
,"IMROWCST" FLOAT(4) NOT NULL
,"IMPAGECST" FLOAT(4) NOT NULL
,"IMRIDSORT" FLOAT(4) NOT NULL
,"IMMERGCST" FLOAT(4) NOT NULL
,"IMCPU" FLOAT(4) NOT NULL
,"IMTOT" FLOAT(4) NOT NULL
,"IMSEQNO" SMALLINT NOT NULL
,"DMPREFH" CHAR(2) NOT NULL
,"DMCLUDIO" FLOAT(4) NOT NULL
,"DMNCLUDIO" FLOAT(4) NOT NULL
,"DMPREDS" INTEGER NOT NULL
,"DMSROWS" FLOAT(4) NOT NULL
,"DMSCANCST" FLOAT(4) NOT NULL
,"DMCOLS" SMALLINT NOT NULL
,"DMROWS" FLOAT(4) NOT NULL
,"RDSROWCST" FLOAT(4) NOT NULL
,"DMPAGECST" FLOAT(4) NOT NULL
,"DMDATAIO" FLOAT(4) NOT NULL
,"DMDATACPU" FLOAT(4) NOT NULL
,"DMDATATOT" FLOAT(4) NOT NULL
,"RDSROW" FLOAT(4) NOT NULL
,"SNCOLS" SMALLINT NOT NULL
,"SNROWS" FLOAT(4) NOT NULL
,"SNRECSZ" INTEGER NOT NULL
,"SNPAGES" FLOAT(4) NOT NULL
,"SNRUNS" FLOAT(4) NOT NULL
,"SNMERGES" FLOAT(4) NOT NULL
,"SNIOCOST" FLOAT(4) NOT NULL
,"SNCPUCOST" FLOAT(4) NOT NULL
,"SNCOST" FLOAT(4) NOT NULL
,"SNSCANIO" FLOAT(4) NOT NULL
,"SNSCANCPU" FLOAT(4) NOT NULL
,"SNSCANCOST" FLOAT(4) NOT NULL
,"SCCOLS" SMALLINT NOT NULL
,"SCROWS" FLOAT(4) NOT NULL
,"SCRECSZ" INTEGER NOT NULL
,"SCPAGES" FLOAT(4) NOT NULL
,"SCRUNS" FLOAT(4) NOT NULL
,"SCMERGES" FLOAT(4) NOT NULL
,"SCIOCOST" FLOAT(4) NOT NULL
,"SCCPUCOST" FLOAT(4) NOT NULL
,"SCCOST" FLOAT(4) NOT NULL
,"SCSCANIO" FLOAT(4) NOT NULL
,"SCSCANCPU" FLOAT(4) NOT NULL
,"SCSCANCOST" FLOAT(4) NOT NULL
,"COMPCARD" FLOAT(4) NOT NULL
,"COMPIOCOST" FLOAT(4) NOT NULL
,"COMPCPUCOST" FLOAT(4) NOT NULL
,"COMPCOST" FLOAT(4) NOT NULL
,"JOINCOLS" SMALLINT NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"COSTBLK" INTEGER NOT NULL
,"COSTSTOR" INTEGER NOT NULL
,"MPBLK" INTEGER NOT NULL
,"MPSTOR" INTEGER NOT NULL
,"COMPOSITES" INTEGER NOT NULL
,"CLIPPED" INTEGER NOT NULL
,"PARTITION" INTEGER NOT NULL
,"TABREF" VARCHAR(64) NOT NULL FOR BIT DATA
,"MAX_COMPOSITES" INTEGER NOT NULL
,"MAX_STOR" INTEGER NOT NULL
,"MAX_CPU" INTEGER NOT NULL
,"MAX_ELAP" INTEGER NOT NULL
,"TBL_JOINED_THRESH" INTEGER NOT NULL
,"STOR_USED" INTEGER NOT NULL
,"CPU_USED" INTEGER NOT NULL
,"ELAPSED" INTEGER NOT NULL
,"MIN_CARD_KEEP" FLOAT(4) NOT NULL
,"MAX_CARD_KEEP" FLOAT(4) NOT NULL
,"MIN_COST_KEEP" FLOAT(4) NOT NULL
,"MAX_COST_KEEP" FLOAT(4) NOT NULL
,"MIN_VALUE_KEEP" FLOAT(4) NOT NULL
,"MIN_VALUE_CARD_KEEP" FLOAT(4) NOT NULL
,"MIN_VALUE_COST_KEEP" FLOAT(4) NOT NULL
,"MAX_VALUE_KEEP" FLOAT(4) NOT NULL
,"MAX_VALUE_CARD_KEEP" FLOAT(4) NOT NULL
,"MAX_VALUE_COST_KEEP" FLOAT(4) NOT NULL
,"MIN_CARD_CLIP" FLOAT(4) NOT NULL
,"MAX_CARD_CLIP" FLOAT(4) NOT NULL
,"MIN_COST_CLIP" FLOAT(4) NOT NULL
,"MAX_COST_CLIP" FLOAT(4) NOT NULL
,"MIN_VALUE_CLIP" FLOAT(4) NOT NULL
,"MIN_VALUE_CARD_CLIP" FLOAT(4) NOT NULL
,"MIN_VALUE_COST_CLIP" FLOAT(4) NOT NULL
,"MAX_VALUE_CLIP" FLOAT(4) NOT NULL
,"MAX_VALUE_CARD_CLIP" FLOAT(4) NOT NULL
,"MAX_VALUE_COST_CLIP" FLOAT(4) NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"PSEQIOCOST" FLOAT(4) NOT NULL
,"PSEQCPUCOST" FLOAT(4) NOT NULL
,"PSEQCOST" FLOAT(4) NOT NULL
,"PADJIOCOST" FLOAT(4) NOT NULL
,"PADJCPUCOST" FLOAT(4) NOT NULL
,"PADJCOST" FLOAT(4) NOT NULL
,"UNCERTAINTY" FLOAT(4) NOT NULL WITH DEFAULT
,"UNCERTAINTY_1T" FLOAT(4) NOT NULL WITH DEFAULT
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
,"IMNP" FLOAT(4) NOT NULL WITH DEFAULT
,"DMNP" FLOAT(4) NOT NULL WITH DEFAULT
,"IMJC" FLOAT(4) NOT NULL WITH DEFAULT
,"IMFC" FLOAT(4) NOT NULL WITH DEFAULT
,"IMJBC" FLOAT(4) NOT NULL WITH DEFAULT
,"IMJFC" FLOAT(4) NOT NULL WITH DEFAULT
,"CRED" INTEGER NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"IXSCAN_SKIP_DUPS" CHAR(1) NOT NULL
WITH DEFAULT 'N'
,"IXSCAN_SKIP_SCREEN" CHAR(1) NOT NULL
WITH DEFAULT 'N'
,"EARLY_OUT" CHAR(1) NOT NULL
WITH DEFAULT ' '
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}L
$@tbAtt;
$@% creIxQE DSN_DETCOST_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_SORT_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_SORT_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"PLANNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"SORTC" CHAR(5) NOT NULL WITH DEFAULT
,"SORTN" CHAR(5) NOT NULL WITH DEFAULT
,"SORTNO" SMALLINT NOT NULL
,"KEYSIZE" SMALLINT NOT NULL
,"ORDERCLASS" INTEGER NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}M
$@tbAtt;
$@% creIxQE DSN_SORT_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_SORTKEY_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_SORTKEY_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"PLANNO" SMALLINT NOT NULL
,"APPLNAME" VARCHAR(24) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"SORTNO" SMALLINT NOT NULL
,"ORDERNO" SMALLINT NOT NULL
,"EXPTYPE" CHAR(3) NOT NULL
,"TEXT" VARCHAR(128) NOT NULL
,"TABNO" SMALLINT NOT NULL
,"COLNO" SMALLINT NOT NULL
,"DATATYPE" CHAR(18) NOT NULL
,"LENGTH" INTEGER NOT NULL
,"CCSID" INTEGER NOT NULL
,"ORDERCLASS" INTEGER NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}N
$@tbAtt;
$@% creIxQE DSN_SORTKEY_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_PGRANGE_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_PGRANGE_TABLE
( "QUERYNO" INTEGER NOT NULL
,"QBLOCKNO" SMALLINT NOT NULL
,"TABNO" SMALLINT NOT NULL
,"RANGE" SMALLINT NOT NULL
,"FIRSTPART" SMALLINT NOT NULL
,"LASTPART" SMALLINT NOT NULL
,"NUMPARTS" SMALLINT NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT
,"PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}O
$@tbAtt;
$@% creIxQE DSN_PGRANGE_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_VIEWREF_TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_VIEWREF_TABLE
( "QUERYNO" INTEGER NOT NULL WITH DEFAULT
,"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT
,"PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"CREATOR" VARCHAR(128) NOT NULL WITH DEFAULT
,"NAME" VARCHAR(128) NOT NULL WITH DEFAULT
,"TYPE" CHAR(1) NOT NULL WITH DEFAULT
,"MQTUSE" SMALLINT NOT NULL WITH DEFAULT
,"EXPLAIN_TIME" TIMESTAMP NOT NULL WITH DEFAULT
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}P
$@tbAtt;
$@% creIxQE DSN_VIEWREF_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_QUERY_TABLE AND ITS INDEXES
CREATE TABLE $cr.DSN_QUERY_TABLE
( "QUERYNO" INTEGER NOT NULL
,"TYPE" CHAR(8) NOT NULL
,"QUERY_STAGE" CHAR(8) NOT NULL
,"SEQNO" INTEGER NOT NULL
,"NODE_DATA" CLOB(2M) NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"QUERY_ROWID" ROWID NOT NULL
GENERATED BY DEFAULT
,"GROUP_MEMBER" VARCHAR(24) NOT NULL
,"HASHKEY" INTEGER NOT NULL
,"HAS_PRED" CHAR(1) NOT NULL
,"SECTNOI" INTEGER NOT NULL WITH DEFAULT
,"APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT
,"PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT
,"COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
,"VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}I
$@tbAtt;
$@% creIxQE DSN_QUERY_TABLE, c
CREATE INDEX $cr.DSN_QUERY_TABLE_IDX2
ON $cr.DSN_QUERY_TABLE
( "QUERYNO"
,"TYPE"
,"QUERY_STAGE"
,"EXPLAIN_TIME"
,"SEQNO"
)
$@ixAtt
;
CREATE UNIQUE INDEX $cr.DSN_QUERY_TABLE_IDX3
ON $cr.DSN_QUERY_TABLE
( "QUERY_ROWID"
)
$@ixAtt
;
-----------------------------------------------------------------------
--CREATE THE AUXILIARY TABLE FOR THE V11 SAMPLE DSN_QUERY_TABLE
--AND ITS INDEX
CREATE AUX TABLE $cr.DSN_QUERY_AUX
IN $db.${tl}I
STORES $cr.DSN_QUERY_TABLE
COLUMN "NODE_DATA"
PART 1;
CREATE INDEX $cr.DSN_QUERY_AUXINX
ON $cr.DSN_QUERY_AUX
$@%¢ixAtt l $!
;
----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_QUERYINFO_TABLE AND ITS AUXILIARY TABLES
--AND INDEXES
CREATE TABLE $cr.DSN_QUERYINFO_TABLE
( "QUERYNO" INTEGER NOT NULL WITH DEFAULT
, "QBLOCKNO" SMALLINT NOT NULL WITH DEFAULT
, "QINAME1" VARCHAR(128) NOT NULL WITH DEFAULT
, "QINAME2" VARCHAR(128) NOT NULL WITH DEFAULT
, "APPLNAME" VARCHAR(24) NOT NULL WITH DEFAULT
, "PROGNAME" VARCHAR(128) NOT NULL WITH DEFAULT
, "VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
, "COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
, "GROUP_MEMBER" VARCHAR(24) NOT NULL WITH DEFAULT
, "SECTNOI" INTEGER NOT NULL WITH DEFAULT
, "SEQNO" INTEGER NOT NULL WITH DEFAULT
, "EXPLAIN_TIME" TIMESTAMP NOT NULL WITH DEFAULT
, "TYPE" CHAR(8) NOT NULL WITH DEFAULT
, "REASON_CODE" SMALLINT NOT NULL WITH DEFAULT
, "QI_DATA" CLOB(2M) NOT NULL WITH DEFAULT
, "SERVICE_INFO" BLOB(2M) NOT NULL WITH DEFAULT
, "QB_INFO_ROWID" ROWID NOT NULL
GENERATED ALWAYS
$@ if $vers >= 11 then $@=¢
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}Q
$@tbAtt;
CREATE AUX TABLE $cr.DSN_QUERYINFO_AUX
IN $db.${tl}Q
STORES $cr.DSN_QUERYINFO_TABLE
COLUMN "QI_DATA"
PART 1;
CREATE INDEX $cr.DSN_QUERYINFO_AUXINX
ON $cr.DSN_QUERYINFO_AUX
$@%¢ixAtt l $!
;
CREATE AUX TABLE $cr.DSN_QUERYINFO_AUX2
IN $db.${tl}R
STORES $cr.DSN_QUERYINFO_TABLE
COLUMN "SERVICE_INFO"
PART 1
;
CREATE INDEX $cr.DSN_QUERYINFO_AUXINX2
ON $cr.DSN_QUERYINFO_AUX2
$@%¢ixAtt l $!
;
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_VIRTUAL_INDEXES TABLE AND ITS INDEX
CREATE TABLE $cr.DSN_VIRTUAL_INDEXES
( "TBCREATOR" VARCHAR(128) NOT NULL
,"TBNAME" VARCHAR(128) NOT NULL
,"IXCREATOR" VARCHAR(128) NOT NULL
,"IXNAME" VARCHAR(128) NOT NULL
,"ENABLE" CHAR(1) NOT NULL
CHECK("ENABLE" IN('Y','N'))
,"MODE" CHAR(1) NOT NULL
CHECK("MODE" IN('C','D'))
,"UNIQUERULE" CHAR(1) NOT NULL
CHECK("UNIQUERULE" IN('D','U'))
,"COLCOUNT" SMALLINT NOT NULL
CHECK("COLCOUNT" > 0)
,"CLUSTERING" CHAR(1) NOT NULL
CHECK("CLUSTERING" IN('Y','N'))
,"NLEAF" INTEGER NOT NULL
CHECK("NLEAF" >= -1)
,"NLEVELS" SMALLINT NOT NULL
CHECK("NLEVELS" >= -1)
,"INDEXTYPE" CHAR(1) NOT NULL WITH DEFAULT
CHECK("INDEXTYPE" IN('D','2'))
,"PGSIZE" SMALLINT NOT NULL
CHECK("PGSIZE" IN(4, 8, 16, 32))
,"FIRSTKEYCARDF" FLOAT NOT NULL WITH DEFAULT -1
CHECK("FIRSTKEYCARDF" = -1
OR "FIRSTKEYCARDF" >= 0)
,"FULLKEYCARDF" FLOAT NOT NULL WITH DEFAULT -1
CHECK("FULLKEYCARDF" = -1
OR "FULLKEYCARDF" >= 0)
,"CLUSTERRATIOF" FLOAT NOT NULL WITH DEFAULT -1
CHECK("CLUSTERRATIOF" = -1
OR "CLUSTERRATIOF" >= 0)
,"PADDED" CHAR(1) NOT NULL WITH DEFAULT
CHECK("PADDED" IN(' ','Y','N'))
,"COLNO1" SMALLINT
CHECK("COLNO1" IS NULL
OR "COLNO1" > 0)
,"ORDERING1" CHAR(1)
CHECK("ORDERING1" IS NULL
OR "ORDERING1" IN('A','D'))
,"COLNO2" SMALLINT
CHECK("COLNO2" IS NULL
OR "COLNO2" > 0)
,"ORDERING2" CHAR(1)
CHECK("ORDERING2" IS NULL
OR "ORDERING2" IN('A','D'))
,"COLNO3" SMALLINT
CHECK("COLNO3" IS NULL
OR "COLNO3" > 0)
,"ORDERING3" CHAR(1)
CHECK("ORDERING3" IS NULL
OR "ORDERING3" IN('A','D'))
,"COLNO4" SMALLINT
CHECK("COLNO4" IS NULL
OR "COLNO4" > 0)
,"ORDERING4" CHAR(1)
CHECK("ORDERING4" IS NULL
OR "ORDERING4" IN('A','D'))
,"COLNO5" SMALLINT
CHECK("COLNO5" IS NULL
OR "COLNO5" > 0)
,"ORDERING5" CHAR(1)
CHECK("ORDERING5" IS NULL
OR "ORDERING5" IN('A','D'))
,"COLNO6" SMALLINT
CHECK("COLNO6" IS NULL
OR "COLNO6" > 0)
,"ORDERING6" CHAR(1)
CHECK("ORDERING6" IS NULL
OR "ORDERING6" IN('A','D'))
,"COLNO7" SMALLINT
CHECK("COLNO7" IS NULL
OR "COLNO7" > 0)
,"ORDERING7" CHAR(1)
CHECK("ORDERING7" IS NULL
OR "ORDERING7" IN('A','D'))
,"COLNO8" SMALLINT
CHECK("COLNO8" IS NULL
OR "COLNO8" > 0)
,"ORDERING8" CHAR(1)
CHECK("ORDERING8" IS NULL
OR "ORDERING8" IN('A','D'))
,"COLNO9" SMALLINT
CHECK("COLNO9" IS NULL
OR "COLNO9" > 0)
,"ORDERING9" CHAR(1)
CHECK("ORDERING9" IS NULL
OR "ORDERING9" IN('A','D'))
,"COLNO10" SMALLINT
CHECK("COLNO10" IS NULL
OR "COLNO10" > 0)
,"ORDERING10" CHAR(1)
CHECK("ORDERING10" IS NULL
OR "ORDERING10" IN('A','D'))
,"COLNO11" SMALLINT
CHECK("COLNO11" IS NULL
OR "COLNO11" > 0)
,"ORDERING11" CHAR(1)
CHECK("ORDERING11" IS NULL
OR "ORDERING11" IN('A','D'))
,"COLNO12" SMALLINT
CHECK("COLNO12" IS NULL
OR "COLNO12" > 0)
,"ORDERING12" CHAR(1)
CHECK("ORDERING12" IS NULL
OR "ORDERING12" IN('A','D'))
,"COLNO13" SMALLINT
CHECK("COLNO13" IS NULL
OR "COLNO13" > 0)
,"ORDERING13" CHAR(1)
CHECK("ORDERING13" IS NULL
OR "ORDERING13" IN('A','D'))
,"COLNO14" SMALLINT
CHECK("COLNO14" IS NULL
OR "COLNO14" > 0)
,"ORDERING14" CHAR(1)
CHECK("ORDERING14" IS NULL
OR "ORDERING14" IN('A','D'))
,"COLNO15" SMALLINT
CHECK("COLNO15" IS NULL
OR "COLNO15" > 0)
,"ORDERING15" CHAR(1)
CHECK("ORDERING15" IS NULL
OR "ORDERING15" IN('A','D'))
,"COLNO16" SMALLINT
CHECK("COLNO16" IS NULL
OR "COLNO16" > 0)
,"ORDERING16" CHAR(1)
CHECK("ORDERING16" IS NULL
OR "ORDERING16" IN('A','D'))
,"COLNO17" SMALLINT
CHECK("COLNO17" IS NULL
OR "COLNO17" > 0)
,"ORDERING17" CHAR(1)
CHECK("ORDERING17" IS NULL
OR "ORDERING17" IN('A','D'))
,"COLNO18" SMALLINT
CHECK("COLNO18" IS NULL
OR "COLNO18" > 0)
,"ORDERING18" CHAR(1)
CHECK("ORDERING18" IS NULL
OR "ORDERING18" IN('A','D'))
,"COLNO19" SMALLINT
CHECK("COLNO19" IS NULL
OR "COLNO19" > 0)
,"ORDERING19" CHAR(1)
CHECK("ORDERING19" IS NULL
OR "ORDERING19" IN('A','D'))
,"COLNO20" SMALLINT
CHECK("COLNO20" IS NULL
OR "COLNO20" > 0)
,"ORDERING20" CHAR(1)
CHECK("ORDERING20" IS NULL
OR "ORDERING20" IN('A','D'))
,"COLNO21" SMALLINT
CHECK("COLNO21" IS NULL
OR "COLNO21" > 0)
,"ORDERING21" CHAR(1)
CHECK("ORDERING21" IS NULL
OR "ORDERING21" IN('A','D'))
,"COLNO22" SMALLINT
CHECK("COLNO22" IS NULL
OR "COLNO22" > 0)
,"ORDERING22" CHAR(1)
CHECK("ORDERING22" IS NULL
OR "ORDERING22" IN('A','D'))
,"COLNO23" SMALLINT
CHECK("COLNO23" IS NULL
OR "COLNO23" > 0)
,"ORDERING23" CHAR(1)
CHECK("ORDERING23" IS NULL
OR "ORDERING23" IN('A','D'))
,"COLNO24" SMALLINT
CHECK("COLNO24" IS NULL
OR "COLNO24" > 0)
,"ORDERING24" CHAR(1)
CHECK("ORDERING24" IS NULL
OR "ORDERING24" IN('A','D'))
,"COLNO25" SMALLINT
CHECK("COLNO25" IS NULL
OR "COLNO25" > 0)
,"ORDERING25" CHAR(1)
CHECK("ORDERING25" IS NULL
OR "ORDERING25" IN('A','D'))
,"COLNO26" SMALLINT
CHECK("COLNO26" IS NULL
OR "COLNO26" > 0)
,"ORDERING26" CHAR(1)
CHECK("ORDERING26" IS NULL
OR "ORDERING26" IN('A','D'))
,"COLNO27" SMALLINT
CHECK("COLNO27" IS NULL
OR "COLNO27" > 0)
,"ORDERING27" CHAR(1)
CHECK("ORDERING27" IS NULL
OR "ORDERING27" IN('A','D'))
,"COLNO28" SMALLINT
CHECK("COLNO28" IS NULL
OR "COLNO28" > 0)
,"ORDERING28" CHAR(1)
CHECK("ORDERING28" IS NULL
OR "ORDERING28" IN('A','D'))
,"COLNO29" SMALLINT
CHECK("COLNO29" IS NULL
OR "COLNO29" > 0)
,"ORDERING29" CHAR(1)
CHECK("ORDERING29" IS NULL
OR "ORDERING29" IN('A','D'))
,"COLNO30" SMALLINT
CHECK("COLNO30" IS NULL
OR "COLNO30" > 0)
,"ORDERING30" CHAR(1)
CHECK("ORDERING30" IS NULL
OR "ORDERING30" IN('A','D'))
,"COLNO31" SMALLINT
CHECK("COLNO31" IS NULL
OR "COLNO31" > 0)
,"ORDERING31" CHAR(1)
CHECK("ORDERING31" IS NULL
OR "ORDERING31" IN('A','D'))
,"COLNO32" SMALLINT
CHECK("COLNO32" IS NULL
OR "COLNO32" > 0)
,"ORDERING32" CHAR(1)
CHECK("ORDERING32" IS NULL
OR "ORDERING32" IN('A','D'))
,"COLNO33" SMALLINT
CHECK("COLNO33" IS NULL
OR "COLNO33" > 0)
,"ORDERING33" CHAR(1)
CHECK("ORDERING33" IS NULL
OR "ORDERING33" IN('A','D'))
,"COLNO34" SMALLINT
CHECK("COLNO34" IS NULL
OR "COLNO34" > 0)
,"ORDERING34" CHAR(1)
CHECK("ORDERING34" IS NULL
OR "ORDERING34" IN('A','D'))
,"COLNO35" SMALLINT
CHECK("COLNO35" IS NULL
OR "COLNO35" > 0)
,"ORDERING35" CHAR(1)
CHECK("ORDERING35" IS NULL
OR "ORDERING35" IN('A','D'))
,"COLNO36" SMALLINT
CHECK("COLNO36" IS NULL
OR "COLNO36" > 0)
,"ORDERING36" CHAR(1)
CHECK("ORDERING36" IS NULL
OR "ORDERING36" IN('A','D'))
,"COLNO37" SMALLINT
CHECK("COLNO37" IS NULL
OR "COLNO37" > 0)
,"ORDERING37" CHAR(1)
CHECK("ORDERING37" IS NULL
OR "ORDERING37" IN('A','D'))
,"COLNO38" SMALLINT
CHECK("COLNO38" IS NULL
OR "COLNO38" > 0)
,"ORDERING38" CHAR(1)
CHECK("ORDERING38" IS NULL
OR "ORDERING38" IN('A','D'))
,"COLNO39" SMALLINT
CHECK("COLNO39" IS NULL
OR "COLNO39" > 0)
,"ORDERING39" CHAR(1)
CHECK("ORDERING39" IS NULL
OR "ORDERING39" IN('A','D'))
,"COLNO40" SMALLINT
CHECK("COLNO40" IS NULL
OR "COLNO40" > 0)
,"ORDERING40" CHAR(1)
CHECK("ORDERING40" IS NULL
OR "ORDERING40" IN('A','D'))
,"COLNO41" SMALLINT
CHECK("COLNO41" IS NULL
OR "COLNO41" > 0)
,"ORDERING41" CHAR(1)
CHECK("ORDERING41" IS NULL
OR "ORDERING41" IN('A','D'))
,"COLNO42" SMALLINT
CHECK("COLNO42" IS NULL
OR "COLNO42" > 0)
,"ORDERING42" CHAR(1)
CHECK("ORDERING42" IS NULL
OR "ORDERING42" IN('A','D'))
,"COLNO43" SMALLINT
CHECK("COLNO43" IS NULL
OR "COLNO43" > 0)
,"ORDERING43" CHAR(1)
CHECK("ORDERING43" IS NULL
OR "ORDERING43" IN('A','D'))
,"COLNO44" SMALLINT
CHECK("COLNO44" IS NULL
OR "COLNO44" > 0)
,"ORDERING44" CHAR(1)
CHECK("ORDERING44" IS NULL
OR "ORDERING44" IN('A','D'))
,"COLNO45" SMALLINT
CHECK("COLNO45" IS NULL
OR "COLNO45" > 0)
,"ORDERING45" CHAR(1)
CHECK("ORDERING45" IS NULL
OR "ORDERING45" IN('A','D'))
,"COLNO46" SMALLINT
CHECK("COLNO46" IS NULL
OR "COLNO46" > 0)
,"ORDERING46" CHAR(1)
CHECK("ORDERING46" IS NULL
OR "ORDERING46" IN('A','D'))
,"COLNO47" SMALLINT
CHECK("COLNO47" IS NULL
OR "COLNO47" > 0)
,"ORDERING47" CHAR(1)
CHECK("ORDERING47" IS NULL
OR "ORDERING47" IN('A','D'))
,"COLNO48" SMALLINT
CHECK("COLNO48" IS NULL
OR "COLNO48" > 0)
,"ORDERING48" CHAR(1)
CHECK("ORDERING48" IS NULL
OR "ORDERING48" IN('A','D'))
,"COLNO49" SMALLINT
CHECK("COLNO49" IS NULL
OR "COLNO49" > 0)
,"ORDERING49" CHAR(1)
CHECK("ORDERING49" IS NULL
OR "ORDERING49" IN('A','D'))
,"COLNO50" SMALLINT
CHECK("COLNO50" IS NULL
OR "COLNO50" > 0)
,"ORDERING50" CHAR(1)
CHECK("ORDERING50" IS NULL
OR "ORDERING50" IN('A','D'))
,"COLNO51" SMALLINT
CHECK("COLNO51" IS NULL
OR "COLNO51" > 0)
,"ORDERING51" CHAR(1)
CHECK("ORDERING51" IS NULL
OR "ORDERING51" IN('A','D'))
,"COLNO52" SMALLINT
CHECK("COLNO52" IS NULL
OR "COLNO52" > 0)
,"ORDERING52" CHAR(1)
CHECK("ORDERING52" IS NULL
OR "ORDERING52" IN('A','D'))
,"COLNO53" SMALLINT
CHECK("COLNO53" IS NULL
OR "COLNO53" > 0)
,"ORDERING53" CHAR(1)
CHECK("ORDERING53" IS NULL
OR "ORDERING53" IN('A','D'))
,"COLNO54" SMALLINT
CHECK("COLNO54" IS NULL
OR "COLNO54" > 0)
,"ORDERING54" CHAR(1)
CHECK("ORDERING54" IS NULL
OR "ORDERING54" IN('A','D'))
,"COLNO55" SMALLINT
CHECK("COLNO55" IS NULL
OR "COLNO55" > 0)
,"ORDERING55" CHAR(1)
CHECK("ORDERING55" IS NULL
OR "ORDERING55" IN('A','D'))
,"COLNO56" SMALLINT
CHECK("COLNO56" IS NULL
OR "COLNO56" > 0)
,"ORDERING56" CHAR(1)
CHECK("ORDERING56" IS NULL
OR "ORDERING56" IN('A','D'))
,"COLNO57" SMALLINT
CHECK("COLNO57" IS NULL
OR "COLNO57" > 0)
,"ORDERING57" CHAR(1)
CHECK("ORDERING57" IS NULL
OR "ORDERING57" IN('A','D'))
,"COLNO58" SMALLINT
CHECK("COLNO58" IS NULL
OR "COLNO58" > 0)
,"ORDERING58" CHAR(1)
CHECK("ORDERING58" IS NULL
OR "ORDERING58" IN('A','D'))
,"COLNO59" SMALLINT
CHECK("COLNO59" IS NULL
OR "COLNO59" > 0)
,"ORDERING59" CHAR(1)
CHECK("ORDERING59" IS NULL
OR "ORDERING59" IN('A','D'))
,"COLNO60" SMALLINT
CHECK("COLNO60" IS NULL
OR "COLNO60" > 0)
,"ORDERING60" CHAR(1)
CHECK("ORDERING60" IS NULL
OR "ORDERING60" IN('A','D'))
,"COLNO61" SMALLINT
CHECK("COLNO61" IS NULL
OR "COLNO61" > 0)
,"ORDERING61" CHAR(1)
CHECK("ORDERING61" IS NULL
OR "ORDERING61" IN('A','D'))
,"COLNO62" SMALLINT
CHECK("COLNO62" IS NULL
OR "COLNO62" > 0)
,"ORDERING62" CHAR(1)
CHECK("ORDERING62" IS NULL
OR "ORDERING62" IN('A','D'))
,"COLNO63" SMALLINT
CHECK("COLNO63" IS NULL
OR "COLNO63" > 0)
,"ORDERING63" CHAR(1)
CHECK("ORDERING63" IS NULL
OR "ORDERING63" IN('A','D'))
,"COLNO64" SMALLINT
CHECK("COLNO64" IS NULL
OR "COLNO64" > 0)
,"ORDERING64" CHAR(1)
CHECK("ORDERING64" IS NULL
OR "ORDERING64" IN('A','D'))
$@ if $vers >= 11 then $@=¢
,"KEYTARGET_COUNT" SMALLINT NOT NULL WITH DEFAULT
CHECK("KEYTARGET_COUNT" >= 0)
,"UNIQUE_COUNT" SMALLINT NOT NULL WITH DEFAULT
CHECK("UNIQUE_COUNT" >= 0)
,"IX_EXTENSION_TYPE" CHAR(1) NOT NULL WITH DEFAULT
CHECK("IX_EXTENSION_TYPE"
IN (' ','S','V'))
,"DATAREPEATFACTORF" FLOAT NOT NULL WITH DEFAULT -1
CHECK("DATAREPEATFACTORF" = -1
OR "DATAREPEATFACTORF" >= 1)
,"SPARSE" CHAR(1) NOT NULL
WITH DEFAULT 'N'
CHECK("SPARSE" IN ('N','Y','X'))
$!
)
IN $db.${ts}J
$@tbAtt;
CREATE INDEX $cr.DSN_VIRTUAL_INDEXES_IDX1
ON $cr.DSN_VIRTUAL_INDEXES
( "TBCREATOR"
,"TBNAME"
)
$@ixAtt
;
$!
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_COLDIST_TABLE
CREATE TABLE $cr.DSN_COLDIST_TABLE
( "QUERYNO" INTEGER NOT NULL
,"APPLNAME" VARCHAR(128) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL
,"GROUP_MEMBER" VARCHAR(128) NOT NULL
,"SECTNOI" INTEGER NOT NULL
,"VERSION" VARCHAR(122) NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"SCHEMA" VARCHAR(128) NOT NULL
,"TBNAME" VARCHAR(128) NOT NULL
,"NAME" VARCHAR(128) NOT NULL
,"COLVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
,"TYPE" CHAR(1) NOT NULL
,"CARDF" FLOAT NOT NULL
,"COLGROUPCOLNO" VARCHAR(254) NOT NULL FOR BIT DATA
,"NUMCOLUMNS" SMALLINT NOT NULL
,"FREQUENCYF" FLOAT NOT NULL
,"QUANTILENO" SMALLINT NOT NULL
,"LOWVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
,"HIGHVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}S
$@tbAtt;
$@% creIxQE DSN_COLDIST_TABLE, c
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_KEYTGTDIST_TABLE
CREATE TABLE $cr.DSN_KEYTGTDIST_TABLE
( "QUERYNO" INTEGER NOT NULL
,"APPLNAME" VARCHAR(128) NOT NULL
,"PROGNAME" VARCHAR(128) NOT NULL
,"COLLID" VARCHAR(128) NOT NULL
,"GROUP_MEMBER" VARCHAR(128) NOT NULL
,"SECTNOI" INTEGER NOT NULL
,"VERSION" VARCHAR(122) NOT NULL
,"EXPLAIN_TIME" TIMESTAMP NOT NULL
,"IXSCHEMA" VARCHAR(128) NOT NULL
,"IXNAME" VARCHAR(128) NOT NULL
,"KEYSEQ" VARCHAR(128) NOT NULL
,"KEYVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
,"TYPE" CHAR(1) NOT NULL
,"CARDF" FLOAT NOT NULL
,"KEYGROUPKEYNO" VARCHAR(254) NOT NULL FOR BIT DATA
,"NUMKEYS" SMALLINT NOT NULL
,"FREQUENCYF" FLOAT NOT NULL
,"QUANTILENO" SMALLINT NOT NULL
,"LOWVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
,"HIGHVALUE" VARCHAR(2000) NOT NULL FOR BIT DATA
$@ if $vers >= 11 then $@=¢
,"EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
$!
)
IN $db.${ts}T
$@tbAtt;
$@% creIxQE DSN_KEYTGTDIST_TABLE, c
$@ if $vers >= 11 then $@=¢
$@ if $queryT then $@=¢
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_PREDICATE_SELECTIVITY TABLE
CREATE TABLE $cr.DSN_PREDICATE_SELECTIVITY
( "QUERYNO" INTEGER NOT NULL
, "QBLOCKNO" SMALLINT NOT NULL
, "APPLNAME" VARCHAR(24) NOT NULL
, "PROGNAME" VARCHAR(128) NOT NULL
, "SECTNOI" INTEGER NOT NULL WITH DEFAULT
, "COLLID" VARCHAR(128) NOT NULL WITH DEFAULT
, "VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
, "PREDNO" INTEGER NOT NULL
, "INSTANCE" SMALLINT NOT NULL
, "SELECTIVITY" FLOAT NOT NULL
, "WEIGHT" FLOAT(4) NOT NULL
, "ASSUMPTION" VARCHAR(128) NOT NULL
, "INSERT_TIME" TIMESTAMP NOT NULL
GENERATED ALWAYS
FOR EACH ROW ON UPDATE
AS ROW CHANGE TIMESTAMP
, "EXPLAIN_TIME" TIMESTAMP
, "REMARKS" VARCHAR(762)
, "EXPANSION_REASON" CHAR(2) NOT NULL WITH DEFAULT
)
IN $db.${ts}U
$@tbAtt;
$@% creIxQE DSN_PREDSEL_IX1, c
$!
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_STAT_FEEDBACK TABLE
CREATE TABLE $cr.DSN_STAT_FEEDBACK
( "QUERYNO" INTEGER NOT NULL
, "APPLNAME" VARCHAR(24) NOT NULL
, "PROGNAME" VARCHAR(128) NOT NULL
, "COLLID" VARCHAR(128) NOT NULL
, "GROUP_MEMBER" VARCHAR(24) NOT NULL
, "EXPLAIN_TIME" TIMESTAMP NOT NULL
, "SECTNOI" INTEGER NOT NULL WITH DEFAULT
, "VERSION" VARCHAR(122) NOT NULL WITH DEFAULT
, "TBCREATOR" VARCHAR(128) NOT NULL
, "TBNAME" VARCHAR(128) NOT NULL
, "IXCREATOR" VARCHAR(128) NOT NULL
, "IXNAME" VARCHAR(128) NOT NULL
, "COLNAME" VARCHAR(128) NOT NULL
, "NUMCOLUMNS" SMALLINT NOT NULL
, "COLGROUPCOLNO" VARCHAR(254) NOT NULL FOR BIT DATA
, "TYPE" CHAR(1) NOT NULL
, "DBNAME" VARCHAR(24) NOT NULL
, "TSNAME" VARCHAR(24) NOT NULL
, "REASON" CHAR(8) NOT NULL
, "REMARKS" VARCHAR(254) NOT NULL
)
IN $db.${ts}W
$@tbAtt;
$@% creIxQE DSN_STAT_FEEDBACK, c
$@ if $queryV then $@=¢
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_VIRTUAL_KEYTARGETS TABLE
CREATE TABLE $cr.DSN_VIRTUAL_KEYTARGETS
( "ENABLE" CHAR(1) NOT NULL
CHECK("ENABLE" IN ('Y','N'))
, "IXNAME" VARCHAR(128) NOT NULL
, "IXSCHEMA" VARCHAR(128) NOT NULL
, "KEYSEQ" SMALLINT NOT NULL WITH DEFAULT
CHECK("KEYSEQ" >= 0)
, "COLNO" SMALLINT NOT NULL WITH DEFAULT
CHECK("COLNO" >= 0)
, "ORDERING" CHAR(1) NOT NULL
CHECK("ORDERING" IN ('A'))
, "TYPESCHEMA" VARCHAR(128) NOT NULL
, "TYPENAME" VARCHAR(128) NOT NULL
, "LENGTH" SMALLINT NOT NULL
CHECK("LENGTH" > 0)
, "LENGTH2" INTEGER NOT NULL
CHECK("LENGTH2" >= 0)
, "SCALE" SMALLINT NOT NULL WITH DEFAULT
CHECK("SCALE" >= 0)
, "NULLS" CHAR(1) NOT NULL
WITH DEFAULT 'N'
CHECK("NULLS" IN ('Y','N'))
, "CCSID" INTEGER NOT NULL
CHECK("CCSID" >= 0)
, "SUBTYPE" CHAR(1) NOT NULL
CHECK("SUBTYPE"
IN ('B','M','S',' '))
, "DERIVED_FROM" VARCHAR(4000) NOT NULL
, "CARDF" FLOAT NOT NULL
WITH DEFAULT -1
CHECK("CARDF" >= 0
OR "CARDF" = -1
OR "CARDF" = -2)
)
IN $db.${ts}X
$@tbAtt;
$!
$!
$/expDdl/
$proc $@=/uQuDdl/
-----------------------------------------------------------------------
-- NAME = DSNTESH aus SDSNSAMP(DSNTESH)
--
-- DESCRIPTIVE NAME = CREATE THE DB2 V11 SAMPLE DSN_USERQUERY_TABLE
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACES FOR THE V11 SAMPLE DSN_USERQUERY_TABLE
CREATE TABLESPACE ${ts}V
IN $db
$@tsAtt
;
--CREATE THE SAMPLE TABLESPACES FOR THE V11 DSN_USERQUERY_TABLE_AUX
CREATE LOB TABLESPACE ${tl}V
IN $db
$@lobAtt
;
-----------------------------------------------------------------------
--CREATE THE V11 SAMPLE DSN_USERQUERY_TABLE
-----------------------------------------------------------------------
CREATE TABLE $cr.DSN_USERQUERY_TABLE
( "QUERYNO" INTEGER NOT NULL PRIMARY KEY
, "SCHEMA" VARCHAR(128) NOT NULL DEFAULT ' '
, "HINT_SCOPE" SMALLINT NOT NULL DEFAULT 0
, "QUERY_TEXT" CLOB(2M) NOT NULL
, "QUERY_ROWID" ROWID NOT NULL GENERATED ALWAYS
, "QUERYID" BIGINT NOT NULL DEFAULT 0
, "USERFILTER" CHAR(8) NOT NULL DEFAULT ' '
, "OTHER_OPTIONS" CHAR(128) NOT NULL DEFAULT ' '
, "COLLECTION" VARCHAR(128) NOT NULL DEFAULT ' '
, "PACKAGE" VARCHAR(128) NOT NULL DEFAULT ' '
, "VERSION" VARCHAR(128) NOT NULL DEFAULT ' '
, "REOPT" CHAR(1) NOT NULL DEFAULT ' '
, "STARJOIN" CHAR(1) NOT NULL DEFAULT ' '
, "MAX_PAR_DEGREE" INTEGER NOT NULL DEFAULT -1
, "DEF_CURR_DEGREE" CHAR(3) NOT NULL DEFAULT ' '
, "SJTABLES" INTEGER NOT NULL DEFAULT -1
, "OTHER_PARMS" VARCHAR(128) NOT NULL DEFAULT ' '
$@ if $vers >= 11 then $@=¢
, "SELECTVTY_OVERRIDE" CHAR(1) NOT NULL DEFAULT 'N'
, "ACCESSPATH_HINT" CHAR(1) NOT NULL DEFAULT ' '
, "OPTION_OVERRIDE" CHAR(1) NOT NULL DEFAULT ' '
$!
)
IN $db.${ts}V
;
CREATE AUX TABLE $cr.DSN_USERQUERY_TABLE_AUX
IN $db.${tl}V
STORES $cr.DSN_USERQUERY_TABLE
COLUMN QUERY_TEXT
PART 1
;
-----------------------------------------------------------------------
--CREATE THE PRIMARY KEY INDEX ON THE V11 SAMPLE DSN_USERQUERY_TABLE
-----------------------------------------------------------------------
CREATE UNIQUE INDEX $cr.DSN_USERQUERY_TABLE_IX1
ON $cr.DSN_USERQUERY_TABLE
( "QUERYNO" ASC
)
$@ixAtt
;
-----------------------------------------------------------------------
--CREATE THE INDEX ON THE V11 SAMPLE DSN_USERQUERY_TABLE AUXILIARY TBL
-----------------------------------------------------------------------
CREATE INDEX $cr.DSN_USERQUERY_TABLE_AUX_IX
ON $cr.DSN_USERQUERY_TABLE_AUX
$@%¢ixAtt l $!
;
$/uQuDdl/
$proc $@/ddlPlus/
if $f2P & ($fun == 'u' | $fun == 'v') then $@¢
if symbol('m.iTb.F2PLAN_TABLE') == 'VAR' then $@¢
tx = m.iTb.F2PLAN_TABLE
if m.iTb.tx.colCount <> 6 | m.iTb.tx.col <> 'IDNO' then $@¢
if $fun == 'v' then $@¢
say 'warning f2Plan_table bad format buf fun = v'
$! else $@¢
if m.iTb.tx.nTables = 1 then
d = 'drop tablespace' m.iTb.tx.db'.'m.iTb.tx.ts
else
d = 'drop table' $cr'.F2PLAN_TABLE'
$$- d'; commit;'
drop m.iTb.F2PLAN_TABLE
$!
$!
$!
$!
if $f2P & ($fun == 'c' | $fun == 'r' ,
| ($fun = 'u' & symbol('m.iTb.F2PLAN_TABLE')<>'VAR')) then $@=¢
-----------------------------------------------------------------------
--CREATE THE SAMPLE TABLESPACES FOR fileAid F2PLAN_TABLE
CREATE TABLESPACE ${ts}0
IN $db
$@tsAtt
;
----fileAid plan table -----------------------------------------
CREATE TABLE $cr.F2PLAN_TABLE
( TIMESTAMP CHAR(16) FOR SBCS DATA NOT NULL
WITH DEFAULT
, STMTNO INTEGER NOT NULL WITH DEFAULT
, SEQNO INTEGER NOT NULL WITH DEFAULT
, TEXT VARCHAR(3800) FOR SBCS DATA NOT NULL
WITH DEFAULT
, REMARKS CHAR(64) FOR Bit DATA NOT NULL
WITH DEFAULT
, IDNO Integer not null with default
)
IN ${db}.${ts}0
$@tbAtt
;
$!
$@/planIx/
$@%¢ixKeys keys drop PLAN_TABLE_idx1 $!
if $keys == 'QUERYNO<EXPLAIN_TIME<' then $@¢
$! else if $fun == 'v' then $@¢
say 'warning fun=v but index PLAN_TABLE_idx1:' $keys
$! else $@=¢
$=doReo=- $doReo | ($defer == 'YES')
$drop
$@% creIxQE PLAN_TABLE
$!
$@%¢ixKeys keys drop PLAN_TABLE_PROG_IX $!
if $keys == 'PROGNAME<COLLID<VERSION<EXPLAIN_TIME<QUERYNO<' ,
then $@¢
$! else if $fun == 'v' then $@¢
say 'warning fun=v but index PLAN_TABLE_PROG_IX:' $keys
$! else $@=¢
$=doReo=- $doReo | ($defer == 'YES')
$drop
CREATE INDEX $cr.PLAN_TABLE_PROG_ix
ON $cr.PLAN_Table
(PROGNAME ASC,
COLLID ASC,
VERSION ASC,
explain_time ASC,
QUERYNO ASC)
$@% ixAtt c
;
$!
$/planIx/
$/ddlPlus/
$proc $@=/creViews/
--- versionen, compiles und explains eines packages -------------------
-- does not work if plan_table ebcdic ||
create view $cr.plan_view0 as
with e as (
select p.collid
, p.name prog
, p.version
, count(e.collid) expCnt
, e.explain_time
, case when e.explain_time is null then 'p'
when e.explain_time > min(p.bindTime) then '>'
when e.explain_time = min(p.bindTime) then '='
else '<' end c
, min(p.pcTimeStamp) pcTimestamp
, min(p.lastUsed) lastUsed
, min(p.conToken) conToken
, sum(case when e.hint_Used = '' or e.hint_Used is null
then 0 else 1 end) hiUse
, sum(case when e.optHint = '' or e.optHint is null
then 0 else 1 end) optHi
, max(max(e.optHint, hint_Used)) hint
from sysIbm.sysPackage p
left join $cr.plan_table e
on e.collid = p.collid and e.progName = p.name
and e.version = p.version
where p.location = ''
group by p.collid, p.name, p.version, e.explain_time
union all select collid
, progName prog
, version
, count(e.collid) expCnt
, e.explain_time
, 'e' c
, cast(null as timestamp) pcTimestamp
, cast(null as date) lastUsed
, cast(null as char(8)) conToken
, sum(case when hint_Used = '' then 0 else 1 end) hiUse
, sum(case when e.optHint = '' then 0 else 1 end) optHi
, max(max(e.optHint, hint_Used)) hint
from $cr.plan_table e
where not exists (select 1 from sysibm.sysPackage p
where e.collid = p.collid and e.progName = p.name
and e.version = p.version and p.location = '' )
group by e.collid, e.progName, e.version, e.explain_time
)
select substr(collid, 1, 6) "collid"
, substr(prog, 1, 8) "prog"
, substr(version, 1, 21) "version"
, smallint(expCnt) "expCnt"
, explain_time, c, pcTimestamp, lastUsed
, smallint(hiUse) "hiUse"
, smallint(optHi) "optHi"
, substr(hint, 1, 8) "hint"
, hex(conToken) conToken, collid, prog, version
, coalesce(pcTimestamp, explain_time) pcEx
from e
;
CREATE VIEW $cr.PLAN_VIEW1 AS
select substr(right(' ' || strip(char(queryNo)) , 6)
|| right(' ' || strip(char(qBlockNo)) , 2)
|| right(' ' || strip(char(planNo)) , 2)
|| right(' ' || strip(char(mixOpSeq)), 1)
,1 ,11) "Queryn B PM",
/* CASE WHEN ACCESSTYPE = 'R ' THEN ' '
when PRIMARY_ACCESSTYPE = 'D' THEN ' '
ELSE SUBSTR(ACCESSNAME, 1, 12) END AS "INDEX", */
SUBSTR(ACCESSNAME, 1, 12) "index",
CASE ACCESSTYPE when ' ' THEN ' '
when 'E ' THEN 'dirRow'
WHEN 'H ' THEN 'hash'
WHEN 'I ' THEN 'ixScan'
WHEN 'IN' THEN 'ixInMe'
WHEN 'I1' THEN 'ixOne '
WHEN 'N ' THEN 'ixScIn'
WHEN 'NR' THEN 'raLiAc'
WHEN 'M ' THEN 'ixMult'
WHEN 'MX' THEN 'ixMSca'
WHEN 'MI' THEN 'ixMInt'
WHEN 'MU' THEN 'ixMUni'
WHEN 'R ' THEN 'tsScan'
WHEN 'RW' THEN 'woScan'
WHEN 'T ' THEN 'ixSPRS'
WHEN 'V ' THEN 'insBuf'
ELSE '??' || primary_accessType || '??'
end
|| CASE PRIMARY_ACCESSTYPE when ' ' then ''
when 'D' then ' dirR'
when 'P' then ' part'
when 'T' then ' spar'
else ' p??'||primary_accessType
END AS ACCESS,
substr(CASE WHEN METHOD = 3 THEN ''
WHEN ACCESSTYPE = 'R ' THEN ''
ELSE right(' ' || MATCHCOLS, 2) || indexOnly
END, 1, 3) AS "mcO",
SUBSTR(TNAME, 1, 12) AS "TABLE",
substr(CASE WHEN A.TABLE_TYPE IS NULL THEN ' '
WHEN A.TABLE_TYPE = 'B' THEN 'buf'
WHEN A.TABLE_TYPE = 'C' THEN 'cte'
WHEN A.TABLE_TYPE = 'F' THEN 'fun'
WHEN A.TABLE_TYPE = 'I' THEN 'inL'
WHEN A.TABLE_TYPE = 'M' THEN 'mqt'
WHEN A.TABLE_TYPE = 'Q' THEN 'vqt'
WHEN A.TABLE_TYPE = 'R' THEN 'rte'
WHEN A.TABLE_TYPE = 'S' THEN 'sub'
WHEN A.TABLE_TYPE = 'T' THEN 'tb '
WHEN A.TABLE_TYPE = 'W' THEN 'wrk'
ELSE A.TABLE_TYPE || '??' END
|| right(' ' || tabNo, 3)
|| ' ' || coalesce(CORRELATION_NAME, '')
, 1, 10) as "tTy no cor",
substr(
CASE JOIN_TYPE WHEN '' THEN ''
WHEN 'F' THEN 'full '
WHEN 'L' THEN 'left '
WHEN 'S' THEN 'star '
ELSE '??' || join_type || ' ' END
|| CASE METHOD when 0 THEN ''
WHEN 1 THEN 'nlJoin'
when 2 THEN 'smJoin'
WHEN 3 THEN 'sort '
WHEN 4 THEN 'hyJoin'
ELSE '' || method END, 1, 8) AS "join/met",
SORTC_UNIQ || SORTC_JOIN || SORTC_ORDERBY || SORTC_GROUPBY
|| ' ' ||
SORTN_UNIQ || SORTN_JOIN || SORTN_ORDERBY || SORTN_GROUPBY
"ujog>ujog",
QBLOCK_TYPE AS "TYPE",
TSLOCKMODE AS LCK,
CASE PARALLELISM_MODE WHEN 'C' THEN 'CPU'
WHEN 'I' THEN 'I-O'
WHEN 'X' THEN 'SYSPLEX'
ELSE NULL END AS PARAL,
STRIP(DIGITS(ACCESS_DEGREE), LEADING, '0') || ' '
|| STRIP(DIGITS(JOIN_DEGREE), LEADING, '0') AS AJ_DEG,
STRIP(DIGITS(ACCESS_PGROUP_ID), LEADING, '0')|| ' '
|| STRIP(DIGITS(JOIN_PGROUP_ID), LEADING, '0') PG_DEG,
STRIP(DIGITS(MERGE_JOIN_COLS), LEADING, '0') AS MC,
PREFETCH AS PRE,
page_range as pgRa,
substr(opthint, 1, 10) optHint,
substr(hint_used, 1, 10) hint_used,
-- full length names
TNAME, ACCESSNAME, accessType, method,
-- package identifikation
collid, progName, applName, version, explain_time,
-- query node identificaten
queryno, qBlockNo, planno, mixopSeq, timestamp,
PARENT_QBLOCKNO
FROM $cr.PLAN_TABLE A
;
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW2 AS
SELECT CASE WHEN METHOD = 3 THEN ' '
ELSE substr(right(' '
|| strip(CHAR(S.PROCMS)),9), 1, 9) END AS MSEC,
a.*,
S.COST_CATEGORY,
S.PROCMS, S.PROCSU, S.REASON
FROM $cr.PLAN_VIEW1 A
LEFT OUTER JOIN
$cr.DSN_STATEMNT_TABLE S
ON S."COLLID" = A."COLLID"
AND S.APPLNAME = A.APPLNAME
AND S.PROGNAME = A.PROGNAME
AND S.EXPLAIN_TIME = A.explain_time
AND S.QUERYNO = A.QUERYNO
;
------------------------------------------------------------------------
$@creViewsFun
-- use of view1 instead of view2 directly
-- because otherwise optimizer makes TS Scan ||||
CREATE VIEW $cr.PLAN_VIEW5 AS
with l as
( select collid, progName, max(r.explain_time) explain_time
FROM $cr.PLAN_TABLE r
group by collid, progName
)
select CASE WHEN METHOD = 3 THEN ' '
ELSE substr(right(' '
|| strip(CHAR(S.PROCMS)),9), 1, 9) END AS MSEC
, a.*
, S.COST_CATEGORY,
S.PROCMS, S.PROCSU, S.REASON
FROM l
join $cr.PLAN_VIEW1 a
on A.collid = l.collid
AND A.PROGNAME = l.PROGNAME
AND A.explain_time = l.explain_time
LEFT OUTER JOIN
$cr.DSN_STATEMNT_TABLE S
ON S."COLLID" = A."COLLID"
AND S.APPLNAME = A.APPLNAME
AND S.PROGNAME = A.PROGNAME
AND S.EXPLAIN_TIME = A.explain_time
AND S.QUERYNO = A.QUERYNO
;
------------ Ende user Views ----- cmnViews = $cmnViews----------------
$@ if $cmnViews then $@=/cmnViews/
$@ call err 'cmnViews are deImplemented'
------------ diese views braucht es nur für changeman -----------------
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW3
( QN,QB,AP,PG, PN,ME,CR,TN,TO, AT,JT,MC,AN,IO, SP,SU,SJ, SO, SG,ZP,ZU,
ZJ, ZO,ZG,TL,TS,PR,EV, CO,VR,MO, AD,AI, JD,JI, PA,MJ,CN, PF,GM,WO,QT,
BT,RM,SD, OH,HU,PAC )
AS SELECT QUERYNO, QBLOCKNO, APPLNAME, PROGNAME, PLANNO, METHOD,
CREATOR, TNAME, TABNO, ACCESSTYPE, JOIN_TYPE, MATCHCOLS, ACCESSNAME,
INDEXONLY, SORTN_PGROUP_ID, SORTN_UNIQ, SORTN_JOIN, SORTN_ORDERBY,
SORTN_GROUPBY, SORTC_PGROUP_ID, SORTC_UNIQ, SORTC_JOIN, SORTC_ORDERBY,
SORTC_GROUPBY, TSLOCKMODE, TIMESTAMP, PREFETCH, COLUMN_FN_EVAL, COLLID,
VERSION, MIXOPSEQ, ACCESS_DEGREE, ACCESS_PGROUP_ID, JOIN_DEGREE,
JOIN_PGROUP_ID, PARALLELISM_MODE, MERGE_JOIN_COLS, CORRELATION_NAME,
PAGE_RANGE, GROUP_MEMBER, WHEN_OPTIMIZE, QBLOCK_TYPE, explain_time,
REMARKS, IBM_SERVICE_DATA, OPTHINT, HINT_USED, PRIMARY_ACCESSTYPE
FROM $cr.PLAN_TABLE
;
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW6 AS
SELECT SUBSTR(A.PROGNAME, 1, 8) AS PROGNAME,
SUBSTR(DIGITS(A."QUERYNO"), 5) AS STMT,
CASE WHEN A.METHOD = 3
THEN ' '
-- ELSE SUBSTR(CHAR(S.PROCSU), 1, 7) END AS SUNITS,
ELSE '1 '
END AS SUNITS,
CASE WHEN A.PRIMARY_ACCESSTYPE = 'D' THEN 'DIR.ROW'
WHEN A.ACCESSTYPE = 'I ' THEN 'IX-SCAN'
WHEN A.ACCESSTYPE = 'I1' THEN 'IX-ONEF'
WHEN A.ACCESSTYPE = 'M ' THEN 'MULT-IX'
WHEN A.ACCESSTYPE = 'MX' THEN 'IX-SC.X'
WHEN A.ACCESSTYPE = 'MI' THEN 'IX-SC.I'
WHEN A.ACCESSTYPE = 'MU' THEN 'IX-SC.U'
WHEN A.ACCESSTYPE = 'N ' THEN 'IX-INLI'
WHEN A.ACCESSTYPE = 'R ' THEN 'TS-SCAN'
WHEN A.ACCESSTYPE = 'RW' THEN 'WF-SCAN'
WHEN A.ACCESSTYPE = 'T ' THEN 'IX-SPRS'
WHEN A.ACCESSTYPE = 'V ' THEN 'BUFFERS'
WHEN A.ACCESSTYPE = ' ' THEN ' '
ELSE ' ' END AS ACCESS,
CASE WHEN A.PRIMARY_ACCESSTYPE = 'D' THEN ' '
WHEN A.ACCESSTYPE = 'R ' THEN ' '
ELSE SUBSTR(A.ACCESSNAME, 1, 12) END AS "INDEX",
CASE WHEN A.TNAME = ' ' THEN ' '
ELSE SUBSTR(A.TNAME, 1, 12) END AS "TABLE",
SUBSTR(A.CORRELATION_NAME, 1, 5) AS CORR,
CASE WHEN A.METHOD = 3 THEN ' '
WHEN A.ACCESSTYPE = 'R ' THEN ' '
WHEN A.QBLOCK_TYPE = 'INSERT' THEN ' '
ELSE SUBSTR(DIGITS(A.MATCHCOLS), 5, 1) END AS MC,
CASE WHEN A.INDEXONLY = 'Y' THEN 'XO'
ELSE ' ' END AS XO,
CASE A.METHOD
WHEN 0 THEN '0 '
WHEN 1 THEN 'NLJOIN'
WHEN 2 THEN 'SMJOIN'
WHEN 3 THEN 'SORT '
WHEN 4 THEN 'HYJOIN'
ELSE CHAR(A.METHOD) END AS METHOD,
CASE A.JOIN_TYPE
WHEN 'F' THEN 'FULL '
WHEN 'L' THEN 'LEFT '
WHEN 'S' THEN 'STAR '
ELSE ' ' END AS "JOIN",
A.SORTN_UNIQ CONCAT A.SORTN_JOIN CONCAT A.SORTN_ORDERBY
CONCAT A.SORTN_GROUPBY AS UJOG,
A.SORTC_UNIQ CONCAT A.SORTC_JOIN CONCAT A.SORTC_ORDERBY
CONCAT A.SORTC_GROUPBY AS UJOC,
A.QBLOCK_TYPE AS QBTYPE,
CASE WHEN A.TABLE_TYPE IS NULL THEN ' '
WHEN A.TABLE_TYPE = 'B' THEN 'BUFFER'
WHEN A.TABLE_TYPE = 'C' THEN 'CTE '
WHEN A.TABLE_TYPE = 'F' THEN 'TBLFNC'
WHEN A.TABLE_TYPE = 'M' THEN 'MQT '
WHEN A.TABLE_TYPE = 'Q' THEN 'VMQT '
WHEN A.TABLE_TYPE = 'R' THEN 'RC#CTE'
WHEN A.TABLE_TYPE = 'T' THEN 'TABLE/'
WHEN A.TABLE_TYPE = 'W' THEN 'WRKFIL'
ELSE A.TABLE_TYPE END AS TTYP,
A.TSLOCKMODE AS LCK,
CASE A.PARALLELISM_MODE
WHEN 'C' THEN 'CPU '
WHEN 'I' THEN 'I-O '
WHEN 'X' THEN 'PLEX'
ELSE ' ' END AS PARAL,
STRIP(DIGITS(A.ACCESS_DEGREE), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(A.JOIN_DEGREE), LEADING, '0')
AS AJ_DEG,
STRIP(DIGITS(A.ACCESS_PGROUP_ID), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(A.JOIN_PGROUP_ID), LEADING, '0')
AS PG_DEG,
STRIP(DIGITS(A.MERGE_JOIN_COLS), LEADING, '0') AS MJC,
CASE A.PREFETCH
WHEN 'S' THEN 'SEQ '
WHEN 'L' THEN 'LIST'
WHEN 'D' THEN 'DYN '
ELSE ' ' END AS PREFETCH,
STRIP(DIGITS(A."QUERYNO"), LEADING, '0') AS QNO,
SUBSTR(DIGITS(A.QBLOCKNO), 4, 2) CONCAT ' '
CONCAT SUBSTR(DIGITS(A.PLANNO), 4, 2)
AS BL_PL,
A.PARENT_QBLOCKNO,
A.QBLOCKNO, A.PLANNO, A.TNAME, A.ACCESSNAME, A.OPTHINT,
A.HINT_USED, A.APPLNAME, A."COLLID", A.VERSION,
A.TIMESTAMP, A.explain_time, A."QUERYNO", A.MIXOPSEQ, A.TABNO,
A.CORRELATION_NAME, A.COLUMN_FN_EVAL, A.SORTC_PGROUP_ID,
A.SORTN_PGROUP_ID, A.PAGE_RANGE, A.WHEN_OPTIMIZE,
A.TABLE_ENCODE, A.TABLE_SCCSID, A.ROUTINE_ID, A.CTEREF,
A.STMTTOKEN,
-- S.COST_CATEGORY, S.PROCMS, S.PROCSU, S.REASON
'A' AS COST_CATEGORY, 1 AS PROCMS, 1 AS PROCSU, ' ' AS REASON
FROM $cr.PLAN_TABLE A
-- JOIN
-- (SELECT B.PROGNAME AS BPROGNAME,
-- B.COLLID AS BCOLLID,
-- MAX(B.explain_time) Bexplain_time
-- FROM $cr.PLAN_TABLE B
-- GROUP BY B.PROGNAME, B.COLLID) AS N1
-- ON A.PROGNAME = N1.BPROGNAME
-- AND A.explain_time = N1.Bexplain_time
-- AND A.COLLID = N1.BCOLLID
-- LEFT OUTER JOIN $cr.DSN_STATEMNT_TABLE S
-- ON S."COLLID" = A."COLLID"
-- AND S.APPLNAME = A.APPLNAME
-- AND S.PROGNAME = A.PROGNAME
-- AND S."QUERYNO" = A."QUERYNO"
-- AND S.EXPLAIN_TIME = A.explain_time
;
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW6_CMN AS
SELECT SUBSTR(A.PROGNAME, 1, 8) AS PROGNAME,
SUBSTR(DIGITS(A."QUERYNO"), 5) AS STMT,
CASE WHEN A.METHOD = 3
THEN ' '
-- ELSE SUBSTR(CHAR(S.PROCSU), 1, 7) END AS SUNITS,
ELSE '1 '
END AS SUNITS,
CASE WHEN A.PRIMARY_ACCESSTYPE = 'D' THEN 'DIR.ROW'
WHEN A.ACCESSTYPE = 'I ' THEN 'IX-SCAN'
WHEN A.ACCESSTYPE = 'I1' THEN 'IX-ONEF'
WHEN A.ACCESSTYPE = 'M ' THEN 'MULT-IX'
WHEN A.ACCESSTYPE = 'MX' THEN 'IX-SC.X'
WHEN A.ACCESSTYPE = 'MI' THEN 'IX-SC.I'
WHEN A.ACCESSTYPE = 'MU' THEN 'IX-SC.U'
WHEN A.ACCESSTYPE = 'N ' THEN 'IX-INLI'
WHEN A.ACCESSTYPE = 'R ' THEN 'TS-SCAN'
WHEN A.ACCESSTYPE = 'RW' THEN 'WF-SCAN'
WHEN A.ACCESSTYPE = 'T ' THEN 'IX-SPRS'
WHEN A.ACCESSTYPE = 'V ' THEN 'BUFFERS'
WHEN A.ACCESSTYPE = ' ' THEN ' '
ELSE ' ' END AS ACCESS,
CASE WHEN A.PRIMARY_ACCESSTYPE = 'D' THEN ' '
WHEN A.ACCESSTYPE = 'R ' THEN ' '
ELSE SUBSTR(A.ACCESSNAME, 1, 12) END AS "INDEX",
CASE WHEN A.TNAME = ' ' THEN ' '
ELSE SUBSTR(A.TNAME, 1, 12) END AS "TABLE",
SUBSTR(A.CORRELATION_NAME, 1, 5) AS CORR,
CASE WHEN A.METHOD = 3 THEN ' '
WHEN A.ACCESSTYPE = 'R ' THEN ' '
WHEN A.QBLOCK_TYPE = 'INSERT' THEN ' '
ELSE SUBSTR(DIGITS(A.MATCHCOLS), 5, 1) END AS MC,
CASE WHEN A.INDEXONLY = 'Y' THEN 'XO'
ELSE ' ' END AS XO,
CASE A.METHOD
WHEN 0 THEN '0 '
WHEN 1 THEN 'NLJOIN'
WHEN 2 THEN 'SMJOIN'
WHEN 3 THEN 'SORT '
WHEN 4 THEN 'HYJOIN'
ELSE CHAR(A.METHOD) END AS METHOD,
CASE A.JOIN_TYPE
WHEN 'F' THEN 'FULL '
WHEN 'L' THEN 'LEFT '
WHEN 'S' THEN 'STAR '
ELSE ' ' END AS "JOIN",
A.SORTN_UNIQ CONCAT A.SORTN_JOIN CONCAT A.SORTN_ORDERBY
CONCAT A.SORTN_GROUPBY AS UJOG,
A.SORTC_UNIQ CONCAT A.SORTC_JOIN CONCAT A.SORTC_ORDERBY
CONCAT A.SORTC_GROUPBY AS UJOC,
A.QBLOCK_TYPE AS QBTYPE,
CASE WHEN A.TABLE_TYPE IS NULL THEN ' '
WHEN A.TABLE_TYPE = 'B' THEN 'BUFFER'
WHEN A.TABLE_TYPE = 'C' THEN 'CTE '
WHEN A.TABLE_TYPE = 'F' THEN 'TBLFNC'
WHEN A.TABLE_TYPE = 'M' THEN 'MQT '
WHEN A.TABLE_TYPE = 'Q' THEN 'VMQT '
WHEN A.TABLE_TYPE = 'R' THEN 'RC#CTE'
WHEN A.TABLE_TYPE = 'T' THEN 'TABLE/'
WHEN A.TABLE_TYPE = 'W' THEN 'WRKFIL'
ELSE A.TABLE_TYPE END AS TTYP,
A.TSLOCKMODE AS LCK,
CASE A.PARALLELISM_MODE
WHEN 'C' THEN 'CPU '
WHEN 'I' THEN 'I-O '
WHEN 'X' THEN 'PLEX'
ELSE ' ' END AS PARAL,
STRIP(DIGITS(A.ACCESS_DEGREE), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(A.JOIN_DEGREE), LEADING, '0')
AS AJ_DEG,
STRIP(DIGITS(A.ACCESS_PGROUP_ID), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(A.JOIN_PGROUP_ID), LEADING, '0')
AS PG_DEG,
STRIP(DIGITS(A.MERGE_JOIN_COLS), LEADING, '0') AS MJC,
CASE A.PREFETCH
WHEN 'S' THEN 'SEQ '
WHEN 'L' THEN 'LIST'
WHEN 'D' THEN 'DYN '
ELSE ' ' END AS PREFETCH,
STRIP(DIGITS(A."QUERYNO"), LEADING, '0') AS QNO,
SUBSTR(DIGITS(A.QBLOCKNO), 4, 2) CONCAT ' '
CONCAT SUBSTR(DIGITS(A.PLANNO), 4, 2)
AS BL_PL,
A.PARENT_QBLOCKNO,
A.QBLOCKNO, A.PLANNO, A.TNAME, A.ACCESSNAME, A.OPTHINT,
A.HINT_USED, A.APPLNAME, A."COLLID", A.VERSION,
A.TIMESTAMP, A.explain_time, A."QUERYNO", A.MIXOPSEQ, A.TABNO,
A.CORRELATION_NAME, A.COLUMN_FN_EVAL, A.SORTC_PGROUP_ID,
A.SORTN_PGROUP_ID, A.PAGE_RANGE, A.WHEN_OPTIMIZE,
A.TABLE_ENCODE, A.TABLE_SCCSID, A.ROUTINE_ID, A.CTEREF,
A.STMTTOKEN,
-- S.COST_CATEGORY, S.PROCMS, S.PROCSU, S.REASON
'A' AS COST_CATEGORY, 1 AS PROCMS, 1 AS PROCSU, ' ' AS REASON
FROM $cr.PLAN_TABLE A
-- JOIN
-- (SELECT B.PROGNAME AS BPROGNAME,
-- B.COLLID AS BCOLLID,
-- MAX(B.explain_time) Bexplain_time
-- FROM $cr.PLAN_TABLE B
-- GROUP BY B.PROGNAME, B.COLLID) AS N1
-- ON A.PROGNAME = N1.BPROGNAME
-- AND A.explain_time = N1.Bexplain_time
-- AND A.COLLID = N1.BCOLLID
-- LEFT OUTER JOIN $cr.DSN_STATEMNT_TABLE S
-- ON S."COLLID" = A."COLLID"
-- AND S.APPLNAME = A.APPLNAME
-- AND S.PROGNAME = A.PROGNAME
-- AND S."QUERYNO" = A."QUERYNO"
-- AND S.EXPLAIN_TIME = A.explain_time
;
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW7 AS
SELECT (
SUBSTR(DIGITS(A."QUERYNO"),5) || ' ' || -- STMT
QBLOCK_TYPE || ' ' || -- TYPE
CASE WHEN METHOD = 3 THEN ' '
ELSE CHAR(S.PROCMS) END || -- MSEC
CASE WHEN PRIMARY_ACCESSTYPE = 'D' THEN 'DIR.ROW'
WHEN ACCESSTYPE = 'I ' THEN 'IX-SCAN'
WHEN ACCESSTYPE = 'I1' THEN 'IX-ONE '
WHEN ACCESSTYPE = 'R ' THEN 'TS-SCAN'
WHEN ACCESSTYPE = 'N ' THEN 'IX-ACC '
WHEN ACCESSTYPE = 'M ' THEN 'IX-SC.M'
WHEN ACCESSTYPE = 'MX' THEN 'IX-SC.X'
WHEN ACCESSTYPE = 'MI' THEN 'IX-SC.I'
WHEN ACCESSTYPE = 'MU' THEN 'IX-SC.U'
WHEN ACCESSTYPE = 'T' THEN 'IX-SPRS'
WHEN ACCESSTYPE = ' ' THEN ' '
ELSE NULL END || ' ' || -- ACCESS
CASE WHEN ACCESSTYPE = 'R' THEN ' '
WHEN PRIMARY_ACCESSTYPE = 'D' THEN ' '
ELSE SUBSTR(ACCESSNAME,1,12) END || ' ' ||
-- "INDEX"
SUBSTR(TNAME,1,18) || ' ' || -- TABLE
CASE WHEN TABLE_TYPE IS NULL THEN ' '
ELSE TABLE_TYPE END || ' ' || -- TTYP
CASE WHEN METHOD = 3 THEN ' '
WHEN ACCESSTYPE = 'R ' THEN ' '
ELSE SUBSTR(DIGITS(MATCHCOLS), 4, 2)
END || ' ' || -- MC_O
CASE WHEN INDEXONLY='Y' THEN 'Y '
ELSE ' '
END || ' ' || -- IXO
CASE WHEN OPTHINT<>' ' THEN '*'
ELSE ' '
END || -- HINT
CASE WHEN HINT_USED<>' ' THEN '*'
ELSE ' '
END -- HINT_USED
) AS TEXT,
CASE METHOD
WHEN 0 THEN ' '
WHEN 1 THEN 'NLJOIN'
WHEN 2 THEN 'SMJOIN'
WHEN 3 THEN 'SORT '
WHEN 4 THEN 'HYJOIN'
ELSE NULL
END AS METHOD,
CASE JOIN_TYPE WHEN 'F' THEN 'FULL ' WHEN 'L' THEN 'LEFT '
WHEN 'S' THEN 'STAR ' ELSE ' ' END AS "JOIN",
SORTN_UNIQ CONCAT SORTN_JOIN CONCAT SORTN_ORDERBY CONCAT
SORTN_GROUPBY AS UJOG,
SORTC_UNIQ CONCAT SORTC_JOIN CONCAT SORTC_ORDERBY CONCAT
SORTC_GROUPBY AS UJOC, TSLOCKMODE AS LCK,
SUBSTR(CORRELATION_NAME, 1, 4) AS CORR,
CASE PARALLELISM_MODE
WHEN 'C' THEN 'CPU'
WHEN 'I' THEN 'I-O'
WHEN 'X' THEN 'SYSPLEX'
ELSE NULL
END AS PARAL,
STRIP(DIGITS(ACCESS_DEGREE), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(JOIN_DEGREE), LEADING, '0') AS AJ_DEG,
STRIP(DIGITS(ACCESS_PGROUP_ID), LEADING, '0') CONCAT ' '
CONCAT STRIP(DIGITS(JOIN_PGROUP_ID), LEADING, '0') AS
PG_DEG,
STRIP(DIGITS(MERGE_JOIN_COLS), LEADING, '0') AS MC,
PREFETCH AS PRE,
STRIP(DIGITS(A."QUERYNO"), LEADING, '0') AS QNO,
SUBSTR(DIGITS(QBLOCKNO), 4, 2) CONCAT ' ' CONCAT SUBSTR(
DIGITS(PLANNO), 4, 2) AS BL_PL,
A.PARENT_QBLOCKNO,
A.QBLOCKNO,
A.PLANNO,
A.TNAME,
A.ACCESSNAME,
A.OPTHINT,
A.HINT_USED,
A.APPLNAME,
A."COLLID",
A.PROGNAME,
A.VERSION,
A.explain_time,
A.TIMESTAMP,
A."QUERYNO",
A.MIXOPSEQ,
S.COST_CATEGORY,
S.PROCMS,
S.PROCSU,
S.REASON
FROM $cr.PLAN_TABLE A
JOIN $cr.DSN_STATEMNT_TABLE S
ON S."COLLID" = A."COLLID"
AND S.APPLNAME = A.APPLNAME
AND S.PROGNAME = A.PROGNAME
AND S."QUERYNO" = A."QUERYNO"
AND S.EXPLAIN_TIME = A.explain_time
;
------------------------------------------------------------------------
CREATE VIEW $cr.PLAN_VIEW9 AS
SELECT A.PROGNAME, A.VERSION, S.PROCMS
FROM $cr.PLAN_TABLE A
LEFT OUTER JOIN $cr.DSN_STATEMNT_TABLE S
ON S."COLLID" = A."COLLID"
AND S.APPLNAME = A.APPLNAME
AND S.PROGNAME = A.PROGNAME
AND S.QUERYNO = A.QUERYNO
AND S.EXPLAIN_TIME = A.explain_time
;
$/cmnViews/
$/creViews/
$proc $@=/creViewsFun/
CREATE VIEW $cr.PLAN_VIEW2Det AS
SELECT oa1p.fqzFmtE7(dmRows) dmRows,
oa1p.fqzFmtE7(rdsRow) rdsRow,
oa1p.fqzFmtE7(snRows) snRows,
oa1p.fqzFmtE7(compCost) compCost,
oa1p.fqzFmtE7(openCost) openCost,
a.*
FROM $cr.PLAN_VIEW1 A
LEFT OUTER JOIN
$cr.DSN_DetCost_TABLE d
on --d.APPLNAME = A.APPLNAME ??? ist manchmal x'0000'
d.PROGNAME = A.PROGNAME
AND d.EXPLAIN_TIME = A.explain_time
AND d.QueryNO = A.QueryNO
AND d.QBlockNO = A.QBlockNO
AND d.PlanNo = A.PlanNo
; $*(
CREATE VIEW $cr.plan_ViewPred as old old
select a."Queryn B PM" "Queryn_B_PM"
, smallint(p.PREDNO) predno
, f.stage
-- , oa1p.fqzFmte7(p.filter_factor) ff
-- optimizer otherwise choose bad path|||
, real(p.FILTER_FACTOR) FILTER_FACTOR
, p.type prTy
, p.boolean_term || ' ' || p.negation "BoN"
, p.text
, p.LEFT_HAND_SIDE
, p.LEFT_HAND_PNO
, p.LHS_TABNO
, p.LHS_QBNO
, p.RIGHT_HAND_SIDE
, p.RIGHT_HAND_PNO
, p.RHS_TABNO
, p.RHS_QBNO
, p.BOOLEAN_TERM
, p.SEARCHARG
, p.JOIN
, p.AFTER_JOIN
, p.ADDED_PRED
, p.REDUNDANT_PRED
, p.DIRECT_ACCESS
, p.KEYFIELD
, p.CATEGORY
, p.CATEGORY_B
, p.PRED_ENCODE
, p.PRED_CCSID
, p.PRED_MCCSID
, p.MARKER
, p.PARENT_PNO
, p.NEGATION
, p.LITERALS
, p.CLAUSE
, f.reEval
, f.ORDERNO
, a.*
from $cr.plan_view1 a
left join $cr.dsn_filter_Table f
on f.applName = a.applName
and f.collid = a.collid
and f.progName = a.progName
and f.explain_time = a.explain_time
and f.QUERYNO = a.QUERYNO
and f.QBLOCKNO = a.QBLOCKNO
and f.PLANNO = a.PLANNO
and f.mixOpSeqNo = a.mixOpSeq
and a.accessType not in ('MX', 'MI', 'MU')
left join $cr.dsn_predicat_table p
on --p.applName = a.applName ??? ist manchmal x'0000'
p.progName = a.progName
and p.explain_time = a.explain_time
and p.queryNo = a.queryNo
and p.qBlockNo = a.qBlockNo
and p.predNo = f.predNo
;
-- sortierung --------------------------------------
-- order by applName, collid, progName, explain_time,
-- queryNo, qBlockNo, planno, mixOpSeq,
-- stage, predNo
$*)
CREATE VIEW $cr.plan_ViewPred as
select substr(right(' ' || strip(char(p.queryNo)) , 6)
|| right(' ' || strip(char(p.qBlockNo)) , 2)
|| right(' ' || strip(value(char(f.planNo), '')) , 2)
|| right(' ' || strip(value(char(f.mixOpSeqNo),'')),1)
,1 ,11) "Queryn B PM"
, smallint(p.PREDNO) prediN
, smallint(f.orderNO) orderN
, f.stage
, oa1p.fqzFmte7(p.filter_factor) ff
, p.type prTy
, p.boolean_term || ' ' || p.negation "BoN"
, p.text
, p.LEFT_HAND_SIDE
, p.LEFT_HAND_PNO
, p.LHS_TABNO
, p.LHS_QBNO
, p.RIGHT_HAND_SIDE
, p.RIGHT_HAND_PNO
, p.RHS_TABNO
, p.RHS_QBNO
, p.BOOLEAN_TERM
, p.SEARCHARG
, p.JOIN
, p.AFTER_JOIN
, p.ADDED_PRED
, p.REDUNDANT_PRED
, p.DIRECT_ACCESS
, p.KEYFIELD
, p.CATEGORY
, p.CATEGORY_B
, p.PRED_ENCODE
, p.PRED_CCSID
, p.PRED_MCCSID
, p.MARKER
, p.PARENT_PNO
, p.NEGATION
, p.LITERALS
, p.CLAUSE
, p.ORIGIN
, p.UNCERTAINTY
, p.QUERYNO, p.QBLOCKNO, p.APPLNAME, p.PROGNAME, p.group_member
, p.SECTNOI, p.COLLID, p.VERSION, p.explain_time, p.predNo
, f.ORDERCLASS
, f.MIXOPSEQNO
, f.REEVAL
, f.PUSHDOWN
, f.planNo
, f.orderNO
from $cr.dsn_predicat_table p
left join $cr.dsn_filter_Table f
on f.progName = p.progName
and f.applName = p.applName -- ??? ist manchmal x'0000'
and f.collid = p.collid
and f.version = p.version
and f.group_member = p.group_member
and f.sectNoi = p.sectNoi
and f.explain_time = p.explain_time
and f.QUERYNO = p.QUERYNO
and f.QBLOCKNO = p.QBLOCKNO
and f.predNo = p.predNo
;
-- sortierung --------------------------------------
-- order by applName, collid, progName, explain_time,
-- queryNo, qBlockNo, predNo, orderNo, mixOpSeqNo
------------------------------------------------------------------------
$/creViewsFun/
$proc $@/viewFunDrop/
call sql2St "select strip(creator) || '.' || strip(name) vw" ,
"from sysibm.sysTables where type = 'V'",
"and name in ('PLAN_VIEW2DET', 'PLAN_VIEWPRED')", vw
$do vx=1 to m.vw.0 $@¢
$$- 'drop view' m.vw.vx.vw';'
$!
$$ commit;
$/viewFunDrop/
$proc $@/viewFunCre/
call sql2St "select strip(creator) cr" ,
"from sysibm.sysTables where type = 'V'",
"and name in ('PLAN_VIEW1')", vw
$do vx=1 to m.vw.0 $@¢
$= cr =- m.vw.vx.cr
$@creViewsFun
$$ commit;
$!
$/viewFunCre/
}¢--- A540769.WK.SQL(PROTPTA) cre=2012-04-12 mod=2016-11-03-09.20.44 A540769 ---
with tb as
( select *
from sysibm.sysTables
where (dbName like 'AV%' or dbName like 'VV%' or dbName like 'NI%'
or name like 'VAV%' or name like 'VVV%' or name like 'VNI%')
)
select type, strip(creator) || '.' || strip(name)
from tb
union all select 'i', strip(creator) || '.' || strip(name)
|| ' on ' || strip(tbcreator) || '.' || strip(tbname)
from sysibm.sysIndexes
where (dbName like 'AV%' or dbName like 'VV%' or dbName like 'NI%'
or name like 'IAV%' or name like 'IVV%' or name like 'INI%')
union all select 'r', strip(Creator) || '.' || strip(tbName)
|| ' ref ' || strip(reftbcreator) || '.' || strip(reftbname)
|| ' ' || strip(char(colCount)) || ' ' || relName
from sysibm.sysRels
where (Creator, tbName) in (select creator, name from tb)
or (refTbCreator, refTbName) in (select creator, name from tb)
union all select 'j', strip(schema) || '.' || strip(Name)
|| ' Trigger ' || trigTime || trigEvent || granularity
|| ' ' || strip(tbowner) || '.' || strip(tbName)
from sysibm.sysTriggers
where (tbowner, tbName) in (select creator, name from tb)
order by 2, 1
$#out 20120416 07:13:13
C COL2
T A230450.VNI145TOCLOSE
T A230450.VNI145TODEL
}¢--- A540769.WK.SQL(PRPLPK) cre=2013-11-18 mod=2016-11-03-09.24.42 A540769 ----
$#@
call sqlConnect dp4g
$;
$<=¢
set current path oa1p ;
with p as
(
select sum(real(p2Commits+aborts)) comR
, sum(real(EDB2TCB)) placpu
, groupName, planName
from pbdd.tacct_general
where dateTime between '2013-11-13-00.00.00'
and '2013-11-13-23.59.59'
group by groupName, planName
)
, q as
(
select
real(occurrences) occ
, real(sqlcount) sqls
, real(cputcbpkg) cpu
, groupName, planName -- , programName
from pbdd.tacct_program
where dateTime between '2013-11-13-00.00.00'
and '2013-11-13-23.59.59'
)
, s as
(
select sum(occ) occ
, sum(sqls) sqls
, sum(cpu) cpu
, groupName, planName--, programName
from q
group by groupName, planName--, programName
)
select fosFmte7(comR) comR
, fosFmte7(plaCpu) plaCpu
, fosFmte7(occ) pkgOcc
, fosFmte7(sqls) sqls
, fosFmte7(cpu) cpu
, p.groupName, p.planName--, programName
from s left join p
on s.groupName = p.groupName and s.planName = p.planName
order by s.occ desc
fetch first 2000 rows only
$!
call sqlStmts
$#out 20131120 09:28:03
sqlCode 0: set current path oa1p
COMR PLACPU PKGOCC SQLS CPU GROUPNAM PLANNAME
1.10E6 6.52E03 1.64E7 2.81E8 6.24E03 DBOF NZ0610
5.91E5 5.61E03 7.65E6 2.00E8 5.53E03 DBOF KC0680
5.28E5 1.16E04 7.45E6 1.36E9 1.11E04 DBOF NZ0920
8.12E5 1.74E03 5.60E6 2.47E7 1.64E03 DBOF CI0700
1.67E5 2.35E03 4.93E6 7.47E7 2.34E03 DBOF CA0410
1.94E5 2.68E03 4.83E6 1.04E8 2.66E03 DBOF KC0830
4.27E5 3.01E03 4.18E6 1.00E8 2.95E03 DBOF BE0630
8.15E5 2.10E03 3.39E6 4.98E7 2.05E03 DBOF CI0900
}¢--- A540769.WK.SQL(PRPLPK2) cre=2013-11-18 mod=2016-11-03-09.25.27 A540769 ---
$#@
$<~WK.SQL(PRPLPKdd)
call sqlConnect dbof
call sqlQueryPrep 7 ,
, "select ( select release from sysibm.sysPlan p" ,
"where p.name = ?) plaR" ,
",(select k.release from sysibm.sysPackage k" ,
"where k.name = ?" ,
"order by k.pcTimestamp desc, k.timestamp desc" ,
"fetch first 1 row only) pkgR from sysibm.sysDummy1"
$@for li $@¢
li = strip($li)
gr = word(li, 6)
pl = word(li, 7)
pr = word(li, 8)
if gr = 'DBOF' then $@¢
call sqlQueryArgs 7, pl, pr
if \ sqlFetch(7, a) then
call err 'no row'
$$- li m.a.plaR'/'m.a.pkgR'.'
call sqlClose 7
$!
$!
$#out 20131118 22:34:36
1.10E6 6.52E3 9.44E5 9.37E6 8.52E02 DBOF NZ0610 YCDSGET C/ .
1.10E6 6.52E3 9.31E5 1.60E8 1.93E03 DBOF NZ0610 YOOAIE3 C/ .
1.10E6 6.52E3 9.23E5 4.15E7 3.22E02 DBOF NZ0610 YCDX031 C/ .
5.91E5 5.61E3 9.18E5 1.12E7 4.49E02 DBOF KC0680 YBER03E C/ .
1.10E6 6.52E3 8.91E5 1.62E6 1.91E02 DBOF NZ0610 YCDQGET C/ .
1.10E6 6.52E3 8.91E5 6.47E6 3.53E02 DBOF NZ0610 YCDOGEE C/ .
}¢--- A540769.WK.SQL(REXXISOL) cre=2016-10-21 mod=2016-10-21-09.58.40 A540769 ---
set current packageSet = 'DSNREXRRA540769';
select count(*), current timestamp, current server
from sysibm.sysTables
}¢--- A540769.WK.SQL(STPRREBI) cre=2011-06-27 mod=2016-11-03-09.26.26 A540769 ---
$#@
call sqlConnect DBAF
if 1 then $@¢
$@do forever $@¢
call sqlStmtsOpt 'call gdb9998.reBi()'
say 'called gdb9998.reBi()'
call sleep 10
call sqlStmtsOpt 'commit'
$!
$! else $@¢
$<=¢
set current sqlid = 's100447' ;
drop procedure gdb9998.ReBi;
terminator } ;
create procedure gdb9998.reBi()
reads sql data
dynamic result sets 1
begin
declare prCu cursor with return for
select *
from A540769.twk982a1
fetch first 10 rows only
;
open prCu;
end
}
terminator ; }
commit;
call gdb9998.reBi();
commit;
$! call sqlStmtsOpt
$!
$#out 20110627 11:32:34
--- called GDB9998.REBI, sqlCode 466
dynamic result set 1 PRCU locator=1
--- begin of dynamic result set 1=PRCU of GDB9998.REBI
T TEXT
0 text 10002 TIMESTAMP
0 text 10005 STARTNUMMER
0 text 10008 DATUM_ZEIT
0 text 10011 ZIELNUMMER
0 text 10014 ANRUFER
0 text 10017 KATEGORIE_ID
0 text 1002 PREDNO
0 text 10020 KATEGORIE_ID
0 text 10023 NAME
0 text 10026 KUNDENNAME
--- 10 rows fetched from dynamic result set 1=PRCU of GDB9998.REBI
sqlCode 466: call gdb9998.reBi()
sqlCode 0: commit
}¢--- A540769.WK.SQL(YDIT002) cre=2014-07-07 mod=2016-11-03-09.21.23 A540769 ---
$#@
call sqlConnect dbof
$;
$<=¢
with s as
(
select distinct DI00202, DI00205, row_number() over () r
FROM oa1p.VDI002A1A
where di00203 = ''
)
select DI00202, DI00205 from s
order by mod(r, 223)
$!
$@..¢sqlRdr()$!
$|
call fTabAuto
$#out 20140707 14:09:06
DI DI00
2 USD
1 0236
}¢--- A540769.WK.SQL(YNZGFM1) cre=2014-07-22 mod=2016-11-03-09.24.06 A540769 ---
$#@
m.vv.1 = 'VNZ100A1V'
m.vv.2 = 'VNZ101A1V'
m.vv.3 = 'VNZ106A1V'
m.vv.4 = 'VNZ111A1V'
m.vv.5 = 'VNZ113A1V'
m.vv.6 = 'VNZ118A1V'
call sqlConnect dbof
$do vx=1 to 5 $@/eachView/
m.vv.vx.0 = 0
call sqlQueryPrep 3, 'select orderRefNumber ord, runningNumber run' ,
'from oa1p.'m.vv.vx 'where orderRefNumber >= ?' ,
'order by orderRefNumber, runningNumber fetch first row only'
ordLa = ''
rL = 0
oL = 0
seq = m.ut_alfNum
$do cx=1 $@/nxRow/
call sqlQueryArgs 3, ordLa
fFou = sqlFetch(3, ff)
call sqlClose 3
if \ fFou then
leave
oL = max(length(strip(m.ff.ord, t)), oL)
rL = max(length(m.ff.run), rL)
call mAdd vv.vx, left(m.ff.ord, 17) || left(m.ff.run, 5)
$** if cx // 2 = 0 then
$** $$- right("|| '", 10)strip(m.ff.ord) m.ff.run+0"'"
ordLa = left(m.ff.ord, 11)
do forever
sx = pos(right(ordLa, 1), seq)
if sx > 0 & sx < length(seq) then
leave
ordLa = left(ordLa, length(ordLa) - 1)
if ordLa = '' then
return err('no next for ordLa' m.ff.ord)
end
ordLa = overlay(substr(seq, sx+1, 1), ordLa, length(ordLa))
$/nxRow/
say vx m.vv.vx m.vv.vx.0 oL rL m.vv.vx.1
$/eachView/
say 'after eachView'
$$- ' /*' sysvar(sysnode) f('%t s') '*/'
do i=1 by 103 to 103001
jx = i // m.vv.3.0 + 1
$$- " || '3"m.vv.3.jx"'"
jy = i // 4
jy = jy + 1 + (jy>1)
jz = i // m.vv.jy.0 + 1
$$- " || '"jy || m.vv.jy.jz"'"
end
$#out 20140728 07:52:12
/* RZ2 2014-07-28-07.52.17 */
|| '3XS80140714800016300001'
|| '21000140709140014400001'
|| '33D00140626800748700001'
|| '13D00140715800002600001'
|| '33D30140618800017000001'
|| '53M80100929800012800010'
|| '33D60140630800189200001'
|| '43N60140702800246300010'