zOs/REXX/WSH30
/* rexx ****************************************************************
wsh: walter's rexx shell version 2.2
interfaces: 17. 6.14
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
|||achtung $@.sqlRdr() funktioniert nicht nur $@..[sqlRdr() $]
||| sqlSel schreib ]$#out |||||
||| einheitliches sql select/rdr syntax in wsh (mit ftab oder ohne|)
|||sql select aus rz2 muss wie csmExRx erfolgen (via WSH) ||||
--- history ------------------------------------------------------------
17.06.14 f: %tS %tT und %tN mit MicroSekunden
*********/ /*** end of help ********************************************
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'
m.mylib = A540769.WK.REXX
call wshLog
m.astSay = 0
parse arg spec
isEdit = 0
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'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & abbrev(m.editDsn, 'A540769.WK.REXX(WS') then
spec = 't'
end
end
if spec = '?' then
return help()
if translate(word(spec, 1)) == 'T' then
return wshTst(subword(spec, 2))
f1 = spec
rest = ''
inp = ''
out = ''
call wshIni
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = file('dd(out)')
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.wshInfo = 'compile'
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit 0
wshIni: procedure expose m.
call compIni
call sqlIni
call scanWinIni
return
endProcedure wshIni
/*--- test hook ----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg cmp
rest = strip(scanLook(m.cmp.scan))
call jClose m.cmp.scan
return wshTst(rest)
endProcedure wshHook_t
wshLog: procedure expose m.
parse arg msg, st
lNm = 'dsn.wsh.log'
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lNm = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lNm '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = 'wshLog' m.myLib'('s3')' sysvar(sysnode) ,
'job='mvsvar('symdef', 'jobname') ,
'user='userid() date('o') 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
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call csmcopy 'CMN.DIV.P0.DB2J.#000197.LLB' ,
, 'RZ1/A540769.TST.LXB'
return 0
call csmcopy 'RZ1/A540769.TST.PS' ,
, 'RZ4/A540769.TST.PO3(EINS)'
return 0
call csmcopy 'RZ1/A540769.TST.LCTL(BBB)',
, 'RZ4/A540769.TST.PS'
return 0
call csmcopy 'A540769.WK.LLB' ,
, 'RZ1/A540769.TST.LLB'
call csmCopL 'RZ4/A540769.WK.JCL(QZ*)',
, 'RZ1/A540769.TST.yCL'
return 0
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect DBAF
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
exit 0
endProcedure wshTst
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg cmp
inp = strip(scanLook(m.cmp.scan))
call jClose m.cmp.scan
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- sql hook -----------------------------------------------------*/
wshHook_S: procedure expose m.
parse arg cmp
s = m.cmp.scan
ki = '='
call scanVerify s, m.m.chSpa
if scanVerify(s, m.comp.chKind) then
ki = left(m.s.tok, 1)
call scanChar s
rest = m.s.tok
call scanNl s
dbSy = word(rest, 1)
if abbrev(dbSy, '-') | \ (length(dbSy) = 4 ,
| (length(dbsy) = 8 & substr(dbSy,4,1) == '/')) then
dbSy = ''
else
rest = subWord(rest, 2)
call sqlConnect dbSy
r = oRunner(compAst2Rx(cmp, ';', compUnit(cmp, ki, '$#')))
call sqlStmtsOpt r, rest
call sqlDisConnect
return ''
endProcedure wshHook_s
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call errMsg ' }'ggTxt
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy time begin -----------------------------------------------------
11.05.23 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
----------------------------------------------------------------------*/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 15
if m.timeReadCvt \== 1 then
call timeReadCvt
uniq = left(uniq, 8, 'A')
d42 = d2x(q2i(uniq, m.timeUQDigits))
d48 = b2x('00'x2b(d42)'000000')
lrsn = right(d2x(x2d(d48) + x2d(m.timeUQZero)), 12, 0)
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 ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.chOp = '.-<@|?%^'
m.comp.chKind = '.-=#@:'
m.comp.chKiNO = '=#:'
call mPut 'COMP.INFO..', "object"
call mPut 'COMP.INFO.-', "string"
call mPut 'COMP.INFO.=', "skeleton"
call mPut 'COMP.INFO.#', "text"
call mPut 'COMP.INFO.@', "rexxShell"
call mPut 'COMP.INFO.:', "pureShell"
m.comp.chDol = '$'
m.comp.chSpa = ' 'x2c('09')
call mPut 'COMP.EXTYPE.b', m.comp.chDol'{}' /* braces */
call mPut 'COMP.EXTYPE.d', m.comp.chDol /* data */
call mPut 'COMP.EXTYPE.s', m.comp.chDol /* strip */
call mPut 'COMP.EXTYPE.w', m.comp.chDol||m.comp.chSpa /* word */
m.comp.idChars = m.ut_alfNum'@_'
m.comp.wCatC = 'compile'
m.comp.wCatO = 'out'
m.comp.wCatS = 'do withNew with for forWith ct proc table'
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'0123456789')
return m
endProcedure compReset
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = j2rdr(src)
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
if spec = '' then
spec = '@'
else
spec = strip(spec, 'l')
if m.m.cmpRdr == '' then do
call scanSrc s, spec
end
else do
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead, spec
end
m.m.out = ''
m.m.end = ''
res = compAst(m, '[')
eOld = m.err.count
do forever
one = ''
if pos(scanLook(s, 1), m.comp.chKind'*') > 0 then do
call scanChar s, 1
ki = m.s.tok
one = compileOne(m, ki)
end
else if \ scanName(s) then do
call scanErr s, 'kind or hook expected after $#'
end
else if m.s.tok == 'out' then do
m.m.out = scanPos(s)
leave
end
else if m.s.tok == 'end' then do
if m.m.end = '' then
m.m.end = scanPos(s)
one = compileOne(m)
end
else if m.s.tok == 'version' then do
call scanSpace s
if \ scanWord(s) | m.s.tok \== '2.0' then
call scanErr s, 'only version 2.0 is supported'
call scanNl s, 1
end
else do
one = compileOne(m, , m.s.tok)
end
if one \== '' then
call mAdd res, one
if scanEnd(s) then
leave
if \ scanLit(s, '$#') then
return scanErr(s, m.comp.info.ki "expected: compile",
ki "stopped before end of input")
end
if m.m.cmpRdr \== '' then
call jClose s
if m.err.count <> eOld then
return ''
if m.astSay then
call compAstSay res, 0
return oRunner(compAst2Rx(m, ';', res))
endProcedure compile
/*--- compile or use hook for one part from spec or input -----------*/
compileOne: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
call compSpComment m
if ki == '*' | m.m.end \== '' then do
do until scanLook(s, 2) == '$#' | scanEnd(s)
call scanNl s, 1
end
return ''
end
if ki \== '' then do
call scanNl s
return compUnit(m, ki, '$#')
end
say 'interpreting hook' hook':' strip(scanLook(s))
interpret return 'wshHook_'hook'(m)'
endProcedure compileOne
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp.chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if pos(ki, '.-=@:') > 0 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 a
end
end
else if ki == '#' then do
res = compAST(m, '[')
call scanChar s
if verify(m.s.tok, m.comp.chSpa) > 0 then
call mAdd res, compAstAddOp(m,
, compAst(m, '=', strip(m.s.tok, 't')), '$')
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAstAddOp(m,
, compAst(m, '=', strip(m.s.src, 't')), '$')
end
return res
end
call err 'bad kind' ki 'in compUnit'
endProcedure compUnit
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
if symbol('m.comp.exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
s = m.m.scan
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-', '='))
astKi = translate(ki, 'os=c', '.-=@')
laPrim = 0
gotTxt = 0
m.res.containsC = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if scanVerify(s, m.comp.exType.type, 'm') then do
one = compAST(m, astKi, 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
one = compPrimary(m, ki)
if one = '' then do
call scanSetPos 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, ki, compOk
s = m.m.scan
ops = ''
if scanLit(s, '.', '-') then
ops = m.s.tok || compOpKi(m, m.s.tok)
getOps = ops
if getOps == '' then
getOps = substr('-.', 1+(ki == '.'), 1)
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), getOps)
r = compVar(m, 'c')
if r \== '' then do
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m,'&',m.r.var, r), getOps)
o2 = ops
do while pos(right(o2, 1) ,'.@') > 0
o2 = left(o2, length(o2)-1)
end
if right(o2, 1) == '^' then
o2 = left(o2, length(o2)-1)
else if compOk \== 1 then
call scanErr s, 'compile can only be used by ^'
return compASTAddOp(m, compAst(m, 'M'), o2)
end
if ops == '' then
return ''
one = compBlock(m, ops)
if one \== '' then
return one
return scanErr(s, 'primary not finished')
endProcedure compPrimary
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, defKi
s = m.m.scan
call scanVerify s, m.comp.chOp || m.comp.chKiNO
op = m.s.tok
kx = verify(op, m.comp.chKiNO, 'm')
if kx = length(op) & op \== '' then
return op
else if kx \== 0 then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
else if pos(right(op, 1), m.comp.chKind'^%') > 0 then
return op
else if defKi == '<' | right(op, 1) == '<' then
return op'='
else if defKi \== '' then
return op || defKi
else
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
old = scanPos(s)
pk = compOpKi(m, ki)
kiFi = left('<', ki =='<')
res = compBlock(m, kiFi || pk)
if res \== '' then do
if length(pk) \== 1 | ki == '<' then
return res
else
return compAstAddOp(m, res, translate(pk, '--', '=#'))
end
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, kiFi || left(pk, length(pk)-1))
call scanSetPos s, old
return res
endProcedure compExprBlock
/*--- 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 do;call compAstSay res, 0
call scanErr s, '$| before statements needed' ; end
call mAdd res, one
end
pre = left(m.comp.chDol, scanLit(s, m.comp.chDol))
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, 'o', ', ')
call mAdd m.res.2, compExprBlock(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 = compExprBlock(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 do
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
end
end
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*/
tb = ''
do forever
if tb \== '' then do
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
if e1 \== '' then do
aa = compAst(m, '[')
fx = 0
do until e1 == ''
do fx=fx+1 to m.tb.0 until px < m.ff.end
ff = m.tb.fx
end
if fx > m.tb.0 then
call scanErr s, 'right of all table fields'
if m.s.pos <= m.ff.pos then
call scanErr s, 'before table field' m.ff.name
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
end
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, 'o', "oNew('"m.tb.class"')"),
, aa, compAst(m, '*', '$.'))
end
nlRi = scanNL(s)
end
else if ki == ':' then do
call compSpNlComment m, '*'
nlRi = 0
end
else if ki == '@' then do
call compSpNlComment m
one = compExpr(m, 's', ki)
if one == '' then
nlRi = 0
else if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
else do
do forever /* scan all continued rexx lines */
nlRi = 1
la = m.one.0
la = m.one.la
if m.la.kind \== 'c' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
call mAdd res, one
end
end
else do
do cc=0 while compComment(m)
end
one = compExpr(m, 'd', ki)
nlRi = scanNL(s)
if one == '' then do
if nlLe & nlRi & cc < 1 then
call mAdd res,compAstAddOp(m,compAst(m,'='),'$')
end
else if m.one.containsD | (nlLe & nlRi,
& \ (cc > 0 | m.one.containsC)) then do
call mAdd res, compAstAddOp(m, one, '$')
end
else do
call mFree one
end
end
nlLe = nlRi
if \ nlRi then do
one = compStmt(m)
if one = '' then
return compAstFree0(res)
if m.one.kind == 'T' then
tb = one
else
call mAdd res, one
end
end
endProcedure compExprStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
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 compAstAddOp(m, compCheckNN(m, compExprBlock(m,'='),
, 'block or expression expected after $$'), '$')
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then do
if wCat == 'v' then
return compAstAddOp(m, compAst(m, '=', fu), '%.&')
if compSpNlComment(m) then
return compAstAddOp(m,
, compCheckNE(m, compExpr(m, 's','@'),
, 'block/primary/expr after $@'), ';')
ops = compOpKi(m, '@')
one = compBlock(m, ops)
if one \== '' then
return one
one = compPrimary(m, right(ops, 1))
if one \== '' then
return compAstAddOp(m, one, ops)
call scanSetPos s, old
return ''
end
if wordPos(fu, 'for forWith with withNew') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m, left('o', fu == 'withNew'))
end
else do
b = compAss(m, '.', 'o')
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compStmt(m), "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b == '' then
call scanErr s, "variable or named block after" fu
b = compAst(m, '=', b)
end
call mAdd res, b, st
if fu == 'withNew' then do
vars = substr(compAstAssignedVars(m.res.2), 3)
m.res.class = classNew('n* CompTable u' vars)
m.res.1 = compAst(m, 'A', ,m.res.1, compAst(m, 'o',
, "oNew('"m.res.class"')"))
end
if abbrev(fu, 'with') then do
r1 = m.res.1
if m.r1.kind == 'A' then do
a1 = m.r1.1
if m.a1.var == 'o' then do
call mAdd res, compAstAddOp(m, m.r1.2, '$.')
m.res.1 = m.r1.2
call mFree a1
end
end
end
return res
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 \== 'c' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compStmt(m), 'stmt after do')
return res
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compStmt(m),
, 'ct statement'));
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compStmt(m), '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 == 'table' then do
call compSpComment m
if scanNl(s) then
call compSpComment m
res = compAst(m, 'T', 'c')
flds = ''
do while compName(m, 'v') == 'v'
f1 = compAst(m, 'T')
m.f1.end = m.s.pos
m.f1.pos = m.s.pos - length(m.s.tok)
m.f1.name = m.s.tok
m.f1.text = 'f' m.f1.name m.f1.pos m.f1.end
call mAdd res, f1
flds = flds', f' m.s.tok 'v'
call compSpComment m
end
if \ scanNl(s) then
call scanErr s, 'name or nl after table expected'
if m.res.0 < 1 then
call scanErr s, 'no names in table'
m.res.class = classNew('n* CompTable u' substr(flds, 3))
m.res.text = 'c' cl
return res
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
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, ki, vk
s = m.m.scan
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
call scanErr s, '= expected in assignment after' pr 'var'
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compExprBlock(m, if(ki=='', '=', ki)),
, 'block or expression in assignment after' pr)
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanErr s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
else
v = compAst(m, '=', v)
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
orOps = ops
s = m.m.scan
if \ scanLit(s, '[', '/') then
return ''
start = m.s.tok
if pos(right(ops, 1), '%^') > 0 then
ops = ops'='
if ops == '' | pos(right(ops, 1), m.comp.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block') /0
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
isCall = pos(right(ops, 1), '%^') > 0
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
if \ isCall then do
res = compUnit(m, ki, stopper)
end
else do
call compSpComment m
res = compPrimary(m, '.', right(ops, 1) == '^')
if m.res.kind == 'M' then
ops = left(ops, length(ops)-1)
else
res = compAst(m, right(ops, 1), , res)
args = compExpr(m, 's', ki)
if args \== '' then
call mAdd res, args
end
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 wordPos(m.s.tok, m.comp.wCatO) > 0 then do
if pos('o', cats) > 0 then
return 'o'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
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
if a == '' then
return 1
do while a \== '' & m.a.kind == '*'
a = m.a.1
end
return a == '' | (m.a.kind \== '[' & m.a.0 < 1)
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
------- atoms, no children
= string constant
----------- rexx fragments
c rexxStatement
s string
o object
r run
f file
------- containers
[ block ==>* c-.
@ code = 1 stmt ==>*
- string
. object
* operand chain ==>1
------- molecules
& 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
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
I?? Input ==>* .
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
call err 'compAST bad kind' ki / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '[@-.*&ABCDFPTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=csorf') > 0 then do
m.n.0 = 'kind'ki
end
else do
call err "compAst kind '"ki"' not supported"
1/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
do while right(ops, 1) == m.a.kind
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
ops = translate(ops, '-', '=')
if m.a.kind \== '*' 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
compAstAssignedVars: procedure expose m.
parse arg a
res = ''
if m.a.kind == 'F' then
return ''
if m.a.kind == 'A' then do
a1 = m.a.1
if m.a1.kind == '=' & m.a1.var == 'v' then do
if words(m.a1.text) \= 1 then
call astErr a1 'bad var'
a2 = m.a.2
say m.a2.kind m.a2.text
if pos(m.a2.kind, '-=s') > 0 ,
| (m.a2.kind == '*' & abbrev(m.a2.text, '-')) then
res = ', f' m.a1.text 'v'
else if pos(m.a2.kind, '.<@o') > 0 ,
| (m.a2.kind == '*' & abbrev(m.a2.text, '.<@')) then
res = ', f' m.a1.text 'r'
else
call astErr a2, 'string or object????'
end
end
if datatype(m.a.0, 'n') then
do ax=1 to m.a.0
res = res || compAstAssignedVars(m.a.ax)
end
return res
endProcedure compAstAssignedVars
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
compAstOnlyOut: procedure expose m.
parse arg a, rec
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind == '*' then
if abbrev(m.a1.text, '$') then
iterate
if m.a1.kind = '[' & rec \== 0 then
if compAstOnlyOut(a1) then
iterate
return 0
end
return 1
endProcedure compAstOnlyOut
/*--- 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
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 o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if pos(o1, '$') > 0 tOnlyOut then
return compCode2rx(m, oR, 'call out' f';')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if o2 \== '.' & o2 \== '<' then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGetO('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 outO' 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
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 o1 == ';' | o1 == '%' then /*??? immer % verwenden ???*/
return compCode2Rx(m, oR, 'call oRun' f';')
return compObj2rx(m, ops, f)
endProcedure compObj2rx
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
if ki == 'c' then
return compCode2Rx(m, ops, m.a.text)
if ki == 's' then
return compString2rx(m, ops, m.a.text)
if ki == 'o' then
return compObj2Rx(m, ops, 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
if m.a.0 = 1 then
return compAst2rx(m, ops, m.a.1)
else
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
if \ compAstOnlyOut(a) then
return compAst2Rx(m, ops';', a)
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind == '*' & abbrev(m.a1.text, '$') then
b = compAst2rx(m, overlay('-',m.a1.text,1), m.a1.1)
else if m.a1.kind == '[' then
b = compAst2rx(m, '-', a1)
else
call compAstErr a, 'onlyOut but' ax'='a1 ,
'kind='m.a1.kind 'text='m.a1.text
res = compCatRexx(res, b, ' ')
end
/* ???? only necessary if part of expression ????*/
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '<' then
return compAst2Rx(m, ops'@', a)
if o1 == '.' then
return compAst2Rx(m, oR'|', a)
if o1 == '|' | o1 == '?' then
if m.a.0 = 1 & compAstOnlyOut(a, 0) then do
a1 = m.a.1
if m.a1.kind \== '*' | \ abbrev(m.a1.text, '$') then
call compAstErr a, 'onlyOut but',
'1='a1 'kind='m.a1.kind 'text='m.a1.text
return compAst2Rx(m, oR'.'substr(m.a1.text, 2), m.a1.1)
end
else
return compFile2Rx(m, ops, compAst2rx(m, '<;', a))
if pos(o1, '@;') > 0 then do
if m.a.0 = 1 then /*???pipe und code können multi stmts */
return compCode2Rx(m, ops, 'do;' ,
compAst2rx(m,';',m.a.1) 'end;')
res = ''
do ax=1 to m.a.0
res = res compAst2rx(m, ';', m.a.ax)
end
if res = '' then
return compCode2Rx(m, ops, 'nop;')
return compCode2Rx(m, ops, 'do;'res 'end;')
end
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, 'vReadO('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
return compRun2Rx(m, ops, c1)
args = compAst2Rx(m, '', m.a.2)
if ki == '%' then
return compCode2Rx(m, ops, 'call oRun' c1',' args';')
call err 'implement'
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 vPutO' nm',' compAst2Rx(m, '.', vl)';')
end
if ki == 'B' then do /* proc */
call vPutO 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, 'with') then do
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPutO ') | right(v, 1) \==';' then
call scanErr s, 'bad vPutO' v
v = 'vPutO('substr(v, 12, length(v)-12)')'
end
if m.a.0 <= 2 then
return 'call vWith "+",' v';' st 'call vWith "-";'
a3 = m.a.3
if m.a3.kind == '*' then
return 'call vWith "+",' v';' st,
compObj2Rx(m, m.a3.text, "vWith('-')")
end
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'forWith' then
st = 'call vWith "=", vGetO('v');' st
if abbrev(m.a.text, 'for') then
st = 'do while vReadO('v');' st 'end;'
if m.a.text == 'forWith' then
st = 'call vWith "+";' st 'call vWith "-";'
return compCode2Rx(m, ops, st)
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, res "call pipe '-';")
end
if ki == 'R' then do /* Run with args */
res = 'call oRun' compAst2Rx(m, , m.a.1)
if m.a.0 > 1 then
res = res',' compAst2Rx(m, , m.a.2)
return compRun2rx(m, ops, res';')
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = ',' compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'compile(comp(j2Buf())' args')')
end
call compAstErr a, 'comAst2rx bad ops' ops 'kind' ki
endProcedure compAst2rx
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
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 scanSB begin ***************************************************
Achtung: inc generiert SB aus scanSB, Aenderungen nur in scanSB|
ScanSB: basic scan
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,...)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
variable interface
scanSrc(m, source) starts scanning a single line
scanEnd(m) : returns whether we reached end of input
scanErr(m, txt): error with current scan location
m is an address, 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
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
/*--- return the next len characters until end of src ----------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src ---------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset ------------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset ------------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End -------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
px = m.m.pos
do forever
px = pos(sep, m.m.src, px)
if px = 0 then do
m.m.tok = ''
return 0
end
px = px + length(sep)
if \ abbrev(substr(m.m.src, px), sep) then do
m.m.tok = substr(m.m.src, m.m.pos, px-m.m.pos)
m.m.pos = px
return 1
end
px = px + 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
t1 = m.m.tok
qu = right(t1, 1)
if \ scanStrEnd(m, qu) then do
m.m.pos = m.m.pos - length(t1)
return scanErr(m, 'ending Apostroph('qu') missing')
end
m.m.val = repAll(left(m.m.tok, length(m.m.tok)-1), qu||qu, qu)
m.m.tok = t1 || m.m.tok
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' '
if \scanUntil(m, stopper) then
return 0
m.m.val = m.m.tok
if ucWord == 1 then
m.m.val = translate(m.m.val)
return 1
endProcedure scanWord
/*--- skip, scan and return next word --------------------------------*/
scanSkWord: procedure expose m.
parse arg m, stopper, ucWord, eMsg
if scanWord(scanSkip(m), stopper, ucWord) then
return m.m.val
else if eMsg == '' then
return ''
else
call scanErr m, eMsg 'expected'
endProcedure scanSkWord
/*--- 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'/0
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value')/0
m.m.pos = cx
return
endProcedure scanBack
/*--- set new src - allow scanning without open ----------------------*/
scanSBSrc: procedure expose m.
parse arg m, m.m.src
return scanSBOpen(m)
endProcedure scanSBSrc
/*--- start scanning with a new single src ---------------------------*/
scanSBOpen: procedure expose m.
parse arg m
m.m.pos = 1
m.m.tok = ''
return m
endProcedure scanSBOpen
/*--- start scanning with a new single src ---------------------------*/
scanSBClose: procedure expose m.
parse arg m
m.m.pos = length(m.m.src) + 1
m.m.tok = '--- closed ---'
return m
endProcedure scanSBClose
scanSBSpace: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
res = nx <> m.m.pos
m.m.tok = left(' ', res)
m.m.pos = nx
return res
endProcedure scanSBSpace
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
scanErr: procedure expose m.
parse arg m, txt
if arg() < 3 then
return err('s}'txt'\n'scanInfo(m))
else
return err('scanErr' txt'\n'arg(3))
endProcedure scanErr
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')
endProcedure scanSBInfo
/*--- return position in simple format -------------------------------*/
scanSBPos: procedure expose m.
parse arg m
return 'singleSrc' m.m.pos
return if(m.m.pos > length(m.m.src), 'E', 'singleSrc' m.m.pos)
/*--- set position to position in arg to------------------------------*/
scanSetPos: 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
/*--- return true if at end of src -----------------------------------*/
scanSBEnd: procedure expose m.
parse arg m
return m.m.pos > length(m.m.src)
/* copy scanSB end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input: with multiple lines
==> all of scanSB
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,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 address, 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
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanSB u JRWO', 'm',
, 'scanEnd return 1',
, 'scanNL m.m.tok = ""; return 0',
, 'scanCom m.m.tok = ""; return 0',
, 'scanInfo return scanSBInfo(m)' ,
, 'jReset call scanSbSrc m, arg;' ,
'call scanOpts m, arg2, arg3, arg(4)',
, "jOpen call scanSBOpen scanOC(m, opt, 'ScanSBR')" ,
, "jClose call scanSBClose scanOC(m, , 'ScanSB')",
, 'scanPos return scanSBPos(m)'
call classNew 'n ScanSBR u ScanSB', 'm',
, "jReadO if scanType(m) == '' then return '';" ,
" else return oClaCopy('"ts"', m, '')"
return
endProcedure scanIni
/*--- check open opt is read and mutate ------------------------------*/
scanOC: procedure expose m.
parse arg m, opt, cla
if \ abbrev(m.j.cRead, opt) then
call err 'scanOpen opt must be' m.j.cRead 'not' opt
return oMutatName(m, cla)
endProcedure scanOC
/*--- start scanning with a new single src ---------------------------*/
scanSrc: procedure expose m.
parse arg m, src
return scanSbSrc(oMutatName(m, 'ScanSB'), src)
scanOpen: procedure expose m.
parse arg m
opt = ''
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanOpen
scanInfo: procedure expose m.
parse arg m
interpret objMet(m, 'scanInfo')
/*--- 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
interpret objMet(m, 'scanEnd')
/*--- scan over white space, nl, comments ...-------------------------*/
scanSpace: procedure expose m.
parse arg m
fnd = 0
do while scanSBSpace(m) | scanCom(m) | scanNl(m)
fnd = 1
end
m.m.tok = left(' ', fnd)
return fnd
endProcedure scanSpace
/*--- scan next line -------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scan one comment -----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
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
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
/*--- 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 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
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
/*--- 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
/*--- emit an error with current scan pos ----------------------------*/
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
/* ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v') */
call classNew 'n ScanRead u ScanSB', 'm',
, 'scanEnd return m.m.atEnd' ,
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanReadCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen scanOC(m, opt, 'ScanReadR')",
", ,arg()>=3, arg(3)" ,
, "jClose call scanReadClose scanOc(m, , 'ScanRead')"
call classNew 'n ScanReadR u ScanRead', 'm',
, 'jReadO' classMet(class4Name('ScanSBR'), 'jReadO')
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 scanReadReset(oNew('ScanRead'), rdr, n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr, n1, np, co
call oMutatName m, 'ScanRead'
call scanOpts m, n1, np, co
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, o, hasLine0, line0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
call jOpen m.m.rdr, '<'
if hasLine0 then do
m.m.pos = 1
m.m.src = line0
end
else
call scanReadNL m, 1
return m
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return scanSBClose(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
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)
return 0
end
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
scanReadCom: 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.pos = 1 + length(m.m.src)
m.m.tok = ' '
return 1
endProcedure scanReadCom
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, 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 classNew 'n ScanWin u ScanSB', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, "jOpen call scanWinOpen scanOC(m, opt, 'ScanWinR'), arg(3)",
, "jClose call scanReadClose scanOC(m, , 'ScanWin')",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)'
call classNew 'n ScanWinR u ScanWin', 'm',
, 'jReadO' classMet(class4Name('ScanSBR'), 'jReadO')
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, m.m.rdr, wiSz, wiGa, cuPo, cuLe
m.m.atEnd = 'closed after reset'
return scanWinOpts(scanOpts(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
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
call scanSBOpen m
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
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 // 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', 'm.m.winTot 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 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
call scanWinRead m
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 do
m.m.tok = ''
return 0
end
m.m.pos = np
end
m.m.tok = ' '
return 1
endProcedure scanWinCom
/*--- scan nl --------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np \= m.m.pos then
return 0
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanEnd(m) then
return 'E'
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 '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 ----------------------------------*/
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 scanSpace(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 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
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 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 ----------------------------------------------*/
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 scanSpace 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 = 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, '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
scan2Trgs: procedure expose m.
parse arg m, t1, t2
cx = m.m.pos - 1
do forever
cx = verify(m.m.src, t1 || t2, 'm', cx + 1)
if cx = 0 then do
m.m.pos = length(m.m.src) + 1
return ''
end
if pos(substr(m.m.src, cx, 1), t1) > 0 then do
m.m.pos = cx
return substr(m.m.src, cx, 1)
end
do ax=4 to arg()
if arg(ax) == substr(m.m.src, cx, length(arg(ax))) then do
m.m.pos = cx
return arg(ax)
end
end
end
endProcedure scan2Trgs
scanSql2Stop: procedure expose m.
parse arg m, sta, stop
sta = substr(sta, 2)
c1 = left(sta, 1)
if c1 == 't' then do
bx = m.m.pos
c1 = scan2Trgs(m, '"'''stop, '-/', '--', '/*')
if bx < m.m.pos then
return 't'sta
m.m.pos = m.m.pos + length(c1)
c1 = left(c1, 1)
sta = c1 || sta
end
if c1 == '/' then do
bx = m.m.pos
c1 = scan2Trgs(m, '"''', '-*', '--', '*/')
if bx < m.m.pos then
return '+'sta
m.m.pos = m.m.pos + length(c1)
if c1 == '*/' then
return sta
c1 = left(c1, 1)
sta = c1 || sta
end
if abbrev(sta, "'") | abbrev(sta, '"') then do
if scanStrEnd(m, c1) then
return sta
m.m.pos = 1 + length(m.m.src)
return '+'sta
end
if pos(c1, '-'stop) > 0 then do
if c1 == '-' then
m.m.pos = length(m.m.src) + 1
return sta
end
if \ abbrev(sta, '/') then
call err 'bad sta2' sta 'for scanSql2Stop'
call err implement
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
endProcedure scanSql2Stop
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = 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, aI
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if pos(oc, 's|fp') > 0 then do
call jClose m.pipe.ax.in
if oc == 'p' then
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
else if oc == '|' then
m.pipe.ax.in = jOpen(oOut, '<')
else if oc == 'f' then do
if arg() <= 3 then
m.pipe.ax.in = jOpen(o2file(aI), '<')
else do
ct = jOpen(Cat(), '>')
do lx = 3 to arg()
call jWriteAll ct, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(ct), '<')
end
end
else if arg() <= 3 then
m.pipe.ax.in = jOpen(jBuf(aI), '<')
else do
bu = jOpen(jBuf(), '>')
do lx = 3 to arg()
call jWrite bu, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(bu), '<')
end
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then
call err 'implement' substr(opts, ox) 'in pipe' opts
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(v, na)
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
tos = m.v_with.0
if fun == '=' then do
if o == '' & m.v_with.tos.obj == '' then
return
if o \== '' & m.v_with.tos.obj \== '' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
return
end
par = tos - 1
end
else if fun == '+' then do
par = tos
tos = tos + 1
m.v_with.0 = tos
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
vGet: procedure expose m.
parse arg na
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
return o2string(mapGet(v, adr))
else if flag == 's' then
return m.adr
else if flag == 'o' then
return o2String(m.adr)
return err('vGet flag' flag)
endProcedure vGet
vGetO: procedure expose m.
parse arg na
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
return mapGet(v, adr)
else if flag == 's' then
return s2o(m.adr)
else if flag == 'o' then
return m.adr
return err('vGetO flag' flag)
endProcedure vGetO
vPut: procedure expose m.
parse arg na, val
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
call mapPut v, adr, s2o(val)
else if flag == 's' then
m.adr = val
else if flag == 'o' then
m.adr = s2o(val)
else
return err('vPut flag' flag)
return val
endProcedure vPut
vPutO: procedure expose m.
parse arg na, val
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
call mapPut v, adr, val
else if flag == 's' then
m.adr = o2String(val)
else if flag == 'o' then
m.adr = val
else
return err('vPutO flag' flag)
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
cx = pos('&', na)
if cx = 1 | na = '' then
return err('vAdr bad name' na)
if m.v_withMap \== '' then do
mp = m.v_withMap
cy = verify(na, '.&', 'm')
if cy < 1 then
w2 = na
else
w2 = left(na, cy - 1)
if symbol('m.mp.w2') == 'VAR' then do
wx = m.mp.w2
return vAdrObj(m.v_with.wx.obj, '.'na)
end
end
if cx < 1 then
oNm = na
else
oNm = left(na, cx-1)
if cx < 1 then
return 'm'na
return vAdrObj(mapGet(v, oNm), '.'substr(na, cx + 1))
endProcedure vAdr
/*--- vAdr for object and field --------------------------------------*/
vAdrObj: procedure expose m.
parse arg o, f
if left(f, 1) == '.' then
cx = 2
else if left(f, 1) == '&' then
cx = 1
else
return err('vAdrObj bad f='f)
do forever
if o = '' then
return err('vAdrObj null at' left(f, cx-1) 'in name' f)
cy = pos('&', f, cx)
if cy < cx then
leave
if cy == cx then
a = o
else
a = o'.'substr(f, cx, cy-cx)
if symbol('m.a') \== 'VAR' then
return err('vAdrObj undef' a 'at' left(f, cy-1) 'in name' f)
o = m.a
cx = cy+1
end
cl = objClass(o, '')
if cl == '' then
return err('vAdrObj undef' o 'in name' f)
return vAdrClass(cl, o, '.'substr(f, cx))
endProcedure vAdrObj
/*--- vAdr for class, object and field -------------------------------*/
vAdrClass: procedure expose m.
parse arg cl, o, f
if pos('&', f) > 0 then
return vAdrObj(o, f)
else if left(f, 1) == '.' then
f2 = substr(f, 2)
else
return err('vAdrClass bad f='f)
f2c = classMet(cl, 'f2c')
if symbol('m.f2c.f2') \== 'VAR' then
return vAdrStem(cl, o, f)
if f2 \== '' then
o = o'.'f2
if m.f2c.f2 == m.class_V then
return 's'o
else
return 'o'o
endProcedure vAdrClass
/*--- vAdr for stems of class, object and field ---------------------*/
vAdrStem: procedure expose m.
parse arg cl, o, f
if left(f, 1) \== '.' & left(f, 1) \== '&' then
return err('vAdrStem bad f='f)
cy = 1
do until cy < 1
cx = cy+1
cy = pos('.', f, cx)
if cy == 0 then do
if verify(f, '0123456789', 'n', cx) >= cx then
call err 'vAdrStem no stem cl' className(cl),
|| ', o' o', f' f
cz = length(f) + 1
end
else do
if verify(f, '0123456789', 'n', cx) \== cy then
iterate
cz = cy
end
end
st = substr(f, 2, max(0, cx-3))
sd = left('.', st \== '')st
sx = substr(f, cx, cz-cx)
if symbol('m.cl.s2c.st') \== 'VAR' then
return err('vAdrStem not a stem cl='className(cl) 'st='st 'o='o)
if sx \== 0 then
return vAdrClass(m.cl.s2c.st, o || sd'.'sx, '.'substr(f, cz))
if cy == 0 then
return 's'o || f
else
return err('vAdrStem.0 not at end cl='cl 'f='f 'o='o)
endProcedure vAdrStem
vRead: procedure expose m.
parse arg na
return in("V."na)
vReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call vPutO na, res
return 1
endProcedure vReadO
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
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'SUBJECT ' subj
m.m.2 = 'RECPLIST ' rec
m.m.3 = 'SENDERID ' if(snd=='', userid(), snd)
m.m.4 = 'SENDERIDCC N'
m.m.5 = 'DOCTEXT'
m.m.0 = 5
return m
endProcedure mailHead
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m, 'DOCTEXTEND'
if dsn == '' then
call dsnAlloc 'dd(iemapi) new ::v255'
else
call dsnAlloc 'dd(iemapi) shr' dsn
call writeDD iemapi, 'M.'m'.'
call tsoClose iemapi
call dsnAlloc 'dd(iemlog) sysout(*)'
call adrTso "call *(os3550)", '*'
if rc \== 0 then
say 'error os3550 rc='rc 'mail not sent|||||'
call tsoFree iemlog iemapi
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_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, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.m.defDD = 'CAT*'
m.fileTso.buf = m.fileTso.buf + 1
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
aDD = word(aa, 1)
aDsn = m.tso_dsn.aDD
if aDsn <> '' then
if pos('(', aDsn) > 0 & pos('/', aDsn) < 1 then
if sysDsn("'"m.tso_dsn.aDD"'") <> 'OK' then
call err 'cannot read' m.tso_dsn.aDD':',
sysDsn("'"m.tso_dsn.aDD"'")
call tsoOpen word(aa, 1), 'R'
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 tsoOpen word(aa, 1), 'W'
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
parse var aa m.m.dd m.m.free
m.m.dsn = mGet('TSO_DSN.'m.m.dd)
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' & m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call tsoClose m.m.dd
call tsoFree 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_V
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_V) == m.class_V then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = oNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree 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 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 sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, cx, tBef, tAft, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
call fTabReset ff, tBef, tAft, '-'
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return
endProcedure sqlFTabReset
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
f1 = m.m.set.sx.fmt
l1 = m.m.set.sx.label
end
end
cx = m.m.sqlX
kx = sqlCol2kx(cx, c1)
if kx == '' then
call err 'colName not found' c1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
if f1 \== '' then do
if right(f1, 1) \== ' ' then
f1 = f1' '
return fTabAdd(m, c1 aDone, f1, l1)
end
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f2 = m.m.sql2fmt.ty
if f2 == 'c' then
f2 = '%-'min(le, m.m.maxChar)'C'
else if f2 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f2 = '%'pr'.'de'i'
end
if \ abbrev(f2, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f2
return fTabAdd(m, c1 aDone, f2' ', l1)
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
do kx=1 to m.sql.cx.d.sqlD
c1 = m.sql.cx.col.kx
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, m.sql.cx.col.kx
end
return
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 100, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 100, '-')
return
endProcedure sqlFTabCol
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabReset ft, cx, 'c 1', '1 c', 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , '%-12H'
call FTabSet ft, 'RBA1' , '%-12H'
call FTabSet ft, 'RBA2' , '%-12H'
call FTabSet ft, 'START_RBA' ,'%-12H'
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlQuery cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAdd ft, substr(tt,length(sep)+1), substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql_dbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
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
call out int || substr(sq, cx, nx-cx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = 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
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 sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
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' ,
', timestamp(rba1 || x''0000'') rba1Tst' ,
', timestamp(rba2 || x''0000'') 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 sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , '%-12H'
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , '%-12H'
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , '%-12H', 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFlds(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut m.ff.fx
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || left('.', m.ff.fx \== '')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"'", ,'')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq, colName, ordering" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql, '?sq col ord'
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 sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sqlO_ini == 1 then
return
call sqlRxIni
m.sqlO_ini = 1
call jIni
call scanIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlRdr u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jReadO return sqlRdrReadO(m)"
call classNew 'n SqlResRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jReadO return sqlRdrReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connection = oNew('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connection = oNew('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connection = 'notConnected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql_connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql_connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql_connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql_connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql_connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- execute stmts with options -------------------------------------*/
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call scanSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
/*--- execute a single sql statement --------------------------------*/
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql_HaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto fTabReset(sql_StmtFmt, 1), rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call 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 assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', inp2str(src, '-sql'), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
m.m.cursor = sqlGetCursor()
if m.m.type == '' then
ff = ''
else do
ff = mCat(classMet(m.m.type, 'oFlds'), ' ')
if abbrev(ff, '. ') then
call err 'sqlRdrOpen implement value for type' m.m.type
ff = space(translate(ff, ' ', '.'), 1)
end
call sqlQuery m.m.cursor, m.m.src, ff
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlRdrO2: procedure expose m.
parse arg m
if m.m.type = '' then do
ff = mCat('SQL.'m.m.cursor'.COL', ' v, f ')
m.m.type = classNew('n* SQL u f' ff 'v')
end
m.m.rowCount = 0
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrReadO: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then
return mFree(v)
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlRdrReadO
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
call sqlRemVars st
feVa = translate(feVa, ' ', '?')
if feVa = '' then do kx=1 to sqlD
call sqlAddVar st, SQLDA_REXXNAME.kx, 1
end
else if abbrev(feVa, ':') then
return err('fetchVars with : for csm:' feVa)
else if words(feVa) <> sqlD then
return err('csm sqlD='sqlD', but' words(feVa) 'vars:' feVa)
else do kx=1 to words(feVa)
call sqlAddVar st, word(feVa, kx), 1
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = m.st.kx
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_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 sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
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 sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: 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 sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
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 sqlRxFetchVars 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 ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
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 sqlRxUpdArgs
/*-- 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 ---------------------*/
sqlRxFetchVars: 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 sqlRxFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
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(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
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 ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) > 0 then
return m.tso_rc
else if wordPos(m.tso_rc, arg(2)) > 0 then
return m.tso_rc
else
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
endProcedure adrCsm
csmDel: procedure expose m.
parse arg rz, dsn
if dsnGetMbr(dsn) == '' then do
call adrCsm "allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)"
call adrTso 'free dd(del1)'
end
else do
rr = adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8)
if rr <> 0 then
if pos('CSMEX77E Member:', m.tso_trap) < 1 ,
| pos(' not found', m.tso_trap) < 1 then
call err 'rc='rr 'csm mDelete' rz'/'dsn':'m.tso_trap
end
return
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse arg aFr, aTo, retOk
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(aFr)
if frMbr == '*' then
fr = dsnSetMbr(aFr)
else
fr = aFr
call csmAlloc fr frDD 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr)
call csmAlloc to toDD 'shr ::D'frDD
if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end
inDD = tsoDD('csmIn*', 'a')
if frMbr == '' & m.tso_dsOrg.frDD == 'PO' then do
call tsoAlloc '-' inDD 'NEW ::F'
call adrCsm "mbrList ddName("frDD") index(' ') short"
do ix=1 to mbr_mem#
i.ix = ' S M='mbr_name.ix
end
call writeDD inDD, 'I.', mbr_mem#
call tsoCLose inDD
end
else do
call adrTso 'alloc dd('inDD') dummy'
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmCopLOld: procedure expose m.
/* csrxUtil geht nicht mit to(mbr), copy geht nicht fuer Load */
parse arg aFr, aTo, retOk
if \ dsnExists(aTo) then do
/* alloc ourself, because csrxutil forget mgmtclas */
call dsnAlloc 'dd(csmCopy) catalog' aTo ,
dsnLikeAtts(dsnSetMbr(aFr), 0)
call tsoFree csmCopy
end
parse value csmSysDsn(aFr) with fSys '/' fDsn
parse value csmSysDsn(aTo) with tSys '/' tDsn
return adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'" ,
"'COPY" fSys"/''"fDsn"'' TO" tSys"/''"tDsn"'' REPLACE'", retOk)
endProcedure csmCopLOld
csmCopyOld: procedure expose m.
parse arg aFr, aTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
fr = csmSysDsn(aFr)
frMbr = dsnGetMbr(fr)
frDD = tsoDD('csmFr*', 'a')
to = csmSysDsn(aTo)
toMbr = dsnGetMbr(to, '=')
toDD = tsoDD('csmTo*', 'a')
call csmAlloc dsnSetMbr(fr) frDD 'shr'
if frMbr == '' & m.tso_dsorg.frDD == 'PO' then
if toMbr \== '=' then
call err 'csmCopy from' fr'(*) to ps' to
else
frMbr = '*'
if frMbr == '' & (toMbr \== '' & toMbr \== '=') then
psOrLib = 'dsorg(po) dsntype(library)'
else if frMbr \== '' & toMbr == '' then
psOrLib = 'dsorg(ps)'
else
psOrLib = ''
call csmAlloc dsnSetMbr(to) toDD 'shr ::D'frDD psOrLib
c = 'indd('frDD') outDD('toDD')'
if frMbr \== '*' then do
if frMbr \== '' then
c = c 'member('frMbr')'
if toMbr \== '' & toMbr \== '=' then
c = c 'newName('toMbr')'
call adrCsm 'copy' c
end
else do
call adrCsm "mbrList ddName("frDD") index(' ') short"
do mx=1 to mbr_mem#
call adrCsm 'copy' c 'member('mbr_name.mx')'
end
end
call tsoFree frDD toDD
return
endProcedure csmCopyOld
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
upper dd disp
m.tso_dsn.dd = csmSysDsn(dsn)
parse var m.tso_dsn.dd sys '/' dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc m.tso_dsn.dd dd 'CAT' rest ':'nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
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
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX'
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 11
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ \== '' then do
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
end
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
if typ == '' then
say left(typ, 10)right(c2, 10) 'ela='e1 'cpu='c1 'su='s1 txt
else
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_rz = ''
m.ii.rzC = ''
i = 'RZ1 1 S1 DBTF T DTF DVTB V DTB DBOC C DOC' ,
'RZ2 2 S2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RR2 R R2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RZ4 4 S4 DBOL O DOL DP4G U DP4' ,
'RZX X X2 DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'RZY Y Y2 DE0G E DE0 DEVG M DEV DPYG Y DPY' ,
'RZZ Z Z2 DE0G E DE0 DEVG M DEV DPZG N DPZ'
m.ii_rz = ''
m.ii_rzC = ''
do wx=1 by 3 to words(i)
parse value subWord(i, wx, 3) with w1 w2 w3
if abbrev(w1, 'R') & length(w1) == 3 then do
rz = w1
m.ii_DbSys.rz = ''
m.ii_rz = strip(m.ii_rz rz)
m.ii_rzC = m.ii_rzC || w2
call iiA1 ii_sys2rz, w3, rz
call iiA1 ii_rz2c, rz, w2
end
else if abbrev(w1, 'D') & length(w1) == 4 then do
m.ii_DbSys.rz = strip(m.ii_DbSys.rz w1)
call iiA1 ii_db2c, w1, w2
call iiA1 ii_mbr2db, w3, w1
end
else
call err 'bad w1' w1 w2 w3
end
return
endProcedure iiIni
iiA1: procedure expose m.
parse arg st, key ,val
if symbol('m.st.key') \== 'VAR' then
m.st.key = val
else if m.st.key \== val then
call err 'already <> defined' st'.'key'='m.st.key 'val='val
return
endProcedure iiA1
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiRz2C
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet == '*' 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' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call saySt(splitNl(err, 'tsoAlloc rc='m.tso_rc ,
'tsoStmt='m.tso_stmt m.tso_trap))
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call 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 \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(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 csv begin *****************************************************/
csvIni: procedure expose m.
if m.csv.ini == 1 then
return
m.csv.ini = 1
call jIni
call classNew "n CsvRdr u JRWO, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvRdrOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvRdr'"
call classNew "n CsvRdrR u CsvRdr", "m",
, "jReadO return csvRdrReadO(m)"
call classNew "n CsvWrt u JRW, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvWrtOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvWrt'"
call classNew "n CsvWrtR u CsvWrt", "m",
, "jRead return csvWrtRead(m, var)"
return
endProcedure csvIni
/*--- create a new csvRdr --------------------------------------------*/
csvRdr: procedure expose m.
parse arg rdr
return jReset(oNew('CsvRdr'), rdr)
endProcedure csvRdr
/*--- open csvRdr: read first line and create dataClass --------------*/
csvRdrOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
if jRead(m.m.rdr, m'.LINE') then do
ff = 'f' repAll(m.m.line, ',', ' v, f ') 'v'
m.m.class = classNew("n* CsvF u" ff)
end
call oMutatName m, 'CsvRdrR'
return
endProcedure csvRdrOpen
/*--- read next line and return derived object -----------------------*/
csvRdrReadO: procedure expose m.
parse arg m
do until m.m.line <> ''
if \ jRead(m.m.rdr, m'.LINE') then
return ''
end
var = oNew(m.m.class)
ff = classMet(m.m.class, 'oFlds')
s = m'.SCAN'
call scanSrc s, m.m.line
do fx=1
f1 = m.ff.fx
if scanString(s, '"') then
m.var.f1 = m.s.val
else do
call scanUntil s, ','
m.var.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
if fx <> m.ff.0 then
call scanerr s, 'csv cla' m.ff.0 'fields but' cx 'in line'
return var
endProcedure csvRdrReadO
/*--- create a new csvRdr --------------------------------------------*/
csvWrt: procedure expose m.
parse arg rdr
return jReset(oNew('CsvWrt'), rdr)
endProcedure csvWrt
/*--- open csvRdr: read first line and create dataClass --------------*/
csvWrtOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
m.m.class = ''
m.m.o1 = ''
call oMutatName m, 'CsvWrtR'
return
endProcedure csvWrtOpen
/*--- read next line and return derived object -----------------------*/
csvWrtRead: procedure expose m.
parse arg m, var
if m.m.o1 == '' then
i1 = jReadO(m.m.rdr)
else do
i1 = m.m.o1
m.m.o1 = ''
end
if i1 == '' then
return 0
if m.m.class == '' then do
m.m.class = objClass(i1)
m.m.o1 = i1
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
t = t','m.ff.fx
end
m.var = substr(t, 2)
return 1
end
else do
m.var = csv4Obj(i1, oFlds(i1), 0)
return 1
end
endProcedure csvWrtRead
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/* copy csv end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
fmt = '@cat%('fmt'%)'
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%.1', m.line)
end
call jClose m
return res || f(fmt'%.2')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
sta = 'tt'
res = ''
do forever
do while scanSBEnd(m)
if \ jCatSqlNl(m) then
return strip(res)
end
bx = m.m.pos
sta = scanSql2Stop(m, sta, stop)
s1 = left(sta, 1)
if pos(s1, stop) > 0 then do
if res <> '' then
return strip(res)
end
else if s1 == '-' | s1 == '/' then
res = res' '
else if pos('/', sta) = 0 then
res = res || substr(m.m.src, bx, m.m.pos - bx)
end
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new ?r return jReset(?new2, arg, arg2, arg3)" ,
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new ?r return jReset(?new1, arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
/*--- open for input given rdr, or stdIn if missing ------------------*/
inOpen: procedure expose m.
parse arg rdr
if rdr == '' then
return jOpen(m.j.in, '<')
else
return jOpen(o2file(rdr), '<')
endProcedure
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if classInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
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 jWriteO m.j.out, arg
return
endProcedure outO
outStem: procedure expose m.
parse arg st
do sx=1 to m.st.0
call jWrite m.j.out, m.st.sx
end
return 0
endProcedure out
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class_V then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class_W then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class_V then
call mAdd m'.BUF', m.ref
else if cl == m.class_W then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = m.ff.fx
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
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in jSingle('m')'
return res
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if 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 arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o_escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.ggClass.method.me') == 'VAR' then
return m.ggClass.method.me
else
return classMet(ggClass, me)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" 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
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class_V m.class_W) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class_V then
l = m.m
else if cl == m.class_W then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = m.ff.fx
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
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_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = ']'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "oCopy return oCopyV(m, t)" ,
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_root = classNew('n root u', 'm',
, "new ?l" ,
, "new1 ?l" ,
, "new2 ?l" ,
, "f2c ?l" ,
, "s2c ?l" ,
, "oClear ?l" ,
, "oFlds ?l" ,
, "oCopy ?l" ,
, "stms ?l" ,
, "s2c ?l" )
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ 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
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 == 0 | n == 1 then do
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
end
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
refs = refs 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
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then
n = classNe1(n, ty, nm, refs, io)
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- 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.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 symbol('m.cl.metLazy.met') == 'VAR' then do
parse var m.cl.metLazy.met l1 lRest
m.cl.method.met = "call err 'building lazy method" cl"#"me"'"
if l1 == '?l' then
m.cl.method.met = classMetLazy(cl, met, lRest)
else if l1 == '?r' then
m.cl.method.met = classMetRec(cl, met, lRest)
else
call err 'implement' l1 'for lazy' className(cl)'#'met
return m.cl.method.met
end
if m.cl.methods == 1 then
return err('no method' met 'in class' className(cl))
m.cl.methods = 1
call classMetGen m.class_root, cl
call classMetGen cl, cl
return classMet(cl, met)
endProcedure classMet
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err implement cycle
endProcedure classCycle
classMetGen: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
if m.cl == 'm' then do
mthd = m.cl.name
/* if mthd = 'jOpen' then trace ?r
if symbol('m.trg.method.mthd') == 'VAR' then nop
else if symbol('m.trg.metLazy.mthd') == 'VAR' then nop
else if \ abbrev(m.cl.met, '?') then
*/ drop m.trg.method.mthd m.trg.metLazy.mthd
if \ abbrev(m.cl.met, '?') then
m.trg.method.mthd = m.cl.met
else
m.trg.metLazy.mthd = m.cl.met
end
else if m.cl == 'u' then do
do cx=1 to m.cl.0
if wordPos(m.cl.cx,
, m.class_V m.class_W m.class_O m.class_R) < 1 then
call classMetGen m.cl.cx, trg, pa
end
end
else if pos(m.cl, 'fscr') < 1 then
call err 'bad cla' cl m.cl
return
endProcedure classMetGen
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classMetLazy: procedure expose m.
parse arg cl, met, rest
if met = 'new1' then do
call mNewArea cl, 'O.'substr(cl,7)
return "oMutate(mNew('"cl"'), '"cl"')"
end
if met == 'oFlds' then do
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
call classFldAdd cl, cl
return cl'.FLDS'
end
call classMet cl, 'oFlds'
if met == 'new' then do
return 'return' classMet(cl, 'new2')
end
else if met == 'new2' then do
call classMet cl, 'oClear'
return "classClear('"cl"'," classMet(cl, 'new1')")"
end
else if wordPos(met, 'f2c stms s2c') > 0 then do
return cl'.'translate(met)
end
else if met == 'oClear' then do
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
end
else if met == 'oCopy' then do
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
s2 = m.cl.s2c.s1
call classMet m.cl.s2c.s1, 'oCopy'
call classMet m.s2.1, 'oCopy'
end
call classMet cl, 'new1'
return "return classCopy('"cl"', m, t)"
end
else
call err 'bad method in classMetLazy('cl',' met')'
endProcedure classMetLazy
classMetRec: procedure expose m.
parse arg cl, met, rest
gen = ''
rx = 1
do forever
ry = pos('?', rest, rx)
if ry == 0 then
return gen || substr(rest, rx)
gen = gen || substr(rest, rx, ry-rx)
rx = verify(rest, m.ut_alfid, 'n', ry+1)
if rx = 0 then
rx = length(rest)+1
gen = gen || classMet(cl, substr(rest, ry+1, rx-ry-1))
end
endProcedure classMetLazy
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if t == '' then
t = oMutate(mNew(cl), cl)
else
call oMutate t, cl
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.stms., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class_V)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class_V then
call out p1 || m.m
else if c == m.class_W then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- 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)
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 outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a, '')
if t = '' 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
/* 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 = 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>.** 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
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return 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
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '@cat%('fmt'%)'
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%.1', m.st.sx)
end
return res || f(fmt'%.2')
endProcedure mCatFT
fGenCat: procedure expose m.
parse arg s, ax
do fx=1 until \ scanLit(s, '%,')
f.fx = fGen(s)
end
if \ scanLit(s, '%)') then
call scanErr s, 'no %) after @fGenCat%('
if \ scanEnd(s) then
call scanErr s, 'mGenCat not at end'
if fx < 2 | f.2 == "''" then
f.2 = fGen(scanSrc(f_u, '%c'))
if fx < 3 then
f.3 = "''"
if fx < 4 then
f.4 = "''"
adr = m.s.src'%'
if f.1 == "''" then
m.f_gen.adr.1 = 'return' f.2
else
m.f_gen.adr.1 = 'return' f.1 '||' f.2
m.f_gen.adr.2 = 'return' f.4
if f.3 == "''" then
return f.2
else
return f.3 '||' f.2
endProcedure fGenCat
mIni: procedure expose m.
if m.m.ini == 1 then
return
m.m.ini = 1
call utIni
m.mBase64 = m.ut_alfUC || m.ut_alfLc || m.ut_digits'+-'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy fTab begin ****************************************************/
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
m.m.set.0 = 0
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
return m
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, tx, t1
m.m.generated = ''
m.m.tit.tx = left(m.m.tit.tx, m.m.len) || t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.label = l1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
k1 = c1
if c1 == '' then
k1 = '='
else if c1 == '=' then
c1 = ''
m.m.cols = m.m.cols k1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' c1 / 0
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after c1' c1
m.m.cx.col = c1
m.m.cx.done = aDone \== 0
if l1 == '' then
m.m.cx.label = k1
else
m.m.cx.label = l1
if cx == 1 then
if abbrev(f1, ' ') then
f1 = substr(f1, 2)
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@.'c1 || substr(f1, px)
call mPut 'F_TEMP'left('.', c1\=='')c1, m.m.cx.label
t1 = f(m.m.cx.fmt, 'F_TEMP')
if pos(strip(t1), m.m.cx.label) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1))m.m.cx.label,
, length(t1))
m.m.cx.len = length(t1)
call fTabAddTit m, 1, t1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
m.m.len = m.m.len + length(t1)
return m
endProcedure fTabAdd
fTabGenerate: procedure expose m.
parse arg m
f = ''
do kx=1 to m.m.0
f = f || m.m.kx.fmt
end
do while right(f, 1) == ' ' & f \== ''
f = left(f, length(f)-1)
end
m.m.fmt = fCache('%.', f)
cSta = m.m.tit.0+3
do cEnd=cSta until kx > m.m.0
cycs = ''
do cx=cSta to cEnd
m.m.tit.cx = ''
cycs = cycs cx
end
cx = cSta
ll = 0
do kx=1 to m.m.0 while length(m.m.tit.cx) < max(ll,1)
m.m.tit.cx = left(m.m.tit.cx, ll)m.m.kx.col
cx = cx + 1
if cx > cEnd then
cx = cSta
ll = ll + m.m.kx.len
end
end
m.m.cycles = strip(cycs)
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = translate(lefPad(m.m.tit.1, m.m.len), '-',' ')'---'
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
l = if(m.m.kx.label == m.m.kx.col, , m.m.kx.label)
f = lefPad(l, 10) lefPad(m.m.kx.col, 18)
if length(f) > 29 then
if length(l || m.m.kx.col) < 29 then
f = l || left('', 29 - length(l||m.m.kx.col))m.m.kx.col
else
f = lefPad(strip(l m.m.kx.col), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
fTab: procedure expose m.
parse arg m, rdr
call fTabBegin m
call fAll m.m.fmt, rdr
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do cx=1 to m.m.0 / 0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m
return fTabTitles(m, m.m.titBef)
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- 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, wiTi
if m == '' then
m = fTabReset(f_auto, 1)
i = j2Buf(rdr)
if m.i.buf.0 <= 0 then
return m
call fTabDetect m, i'.BUF', wiTi
return fTab(m, i)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b, wiTi
ff = oFlds(m.b.1)
do fx=1 to m.ff.0
call fTabAddDetect m, m.ff.fx, b
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabAddDetect: procedure expose m.
parse arg m, c1 aDone, st, l1
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
suf = left('.', c1 \== '')c1
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
call fTabAdd m, c1 aDone, ' %'newFo, l1
/* say c1 '????==> %'newFo */
return newFo
endProcedure fTabAddDetect
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5m43 --------*/
fTime: procedure expose m.
parse arg s, signed
return fUnits(s, 't', signed==1)
endProcedure fTime
fDec: procedure expose m.
parse arg s, signed
return fUnits(s, 'd', signed==1)
endProcedure fDec
fUnits: procedure expose m.
parse arg s, scale, signed
if f_units_ini \== 1 then do
f_units_ini = 1
call fUnitsIni 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fUnitsIni 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
end
if s >= 0 then
res = fUnitsNN(s, scale, wi)
else
res = '-'fUnitsNN(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 fUnits
fUnitsNN: 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 'fUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fUnitsNN
fUnitsIni: 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 'fUnitsIni 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 fUnitsIni
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fCache ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.ggFmt
endProcedure fImm
/*--- compile format fmt put in the cache with address a ------------*/
fCache: procedure expose m.
parse arg a, fmt
if a == '%.' then 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
else if symbol('M.f_gen.a') == 'VAR' then
return a
if symbol('m.f_s_0') \== 'VAR' | m.f_s_0 == 0 then
m.f_s_0 = 1
else do
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
end
call scanSrc f_s, fmt
m.f_gen.a = 'return' fGen(f_s)
m.f_s_0 = m.f_s_0 - 1
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
return a
endProcedure fCache
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y
- (,) call format generator routine with name 'fGen' || field
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg f_s
ax = 0
cd = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
if scanWhile(f_s, '0123456789') then
len = m.f_s.tok
else
len = 0
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 then
aa = 'ggA'ax
else
aa = 'arg(' || (ax+1) || ')'
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len < 1 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 < 1 then
cd = cd')'
else
cd = cd',' len')'
end
else if len < 1 then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," word(prec 0, 1)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," word(prec 0, 1)")"
else if sp == 'E' | sp == 'e' then do
if len = 0 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 = '(' then do
if af == '' | flags \== '' | len \== 0 | prec \== '' then
call scanErr f_s, "bad call shoud be @sub%("
interpret "cRes = fGen"af"(f_s, ax)"
cd = cd '||' cRes
if \ scanLit(f_s, '%)') then
if \ scanEnd(f_s) then
call scanErr f_s, '%) to end call' af 'expected'
end
else do
call scanBack f_s, '%'sp
leave
end
end
if cd \== '' then
return substr(cd, 5)
else
return "''"
endProcedure fGen
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if \ scanLit(f_s, '%%', '%@') then
return res
res = res || substr(m.f_s.tok, 2)
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = inOpen(rdr)
o = jReadO(i)
do while o \== ''
call out f(fmt, o)
o = jReadO(i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 ---------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ----------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*--- generate timestamp formats: from format c to format d ----------*/
fTstGen: procedure expose m.
parse arg c 2 d, s
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
a = 'F_TSTFO.'
/* Y: A = 2010, M:B=Januar,
H=Stunde A=0 B=10 C=20
jkl = julian day
yyyy-mm-dd-hh.mm.ss.ffffff */
call mPut a'S', 'yz34-56-78-hi.mn.st.abcdef'
call mPut a's', 'yz34-56-78-hi.mn.st'
call mPut a' '
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78'
call mPut a'M', 'M78himns'
call mPut a'A', 'A8himnst'
call mPut a'H', 'Himnst'
call mPut a'n', 'yz345678 hi:mn:st'
call mPut a'N', 'yz345678 hi:mn:st.abcdef'
return fTstGen(cd, s)
end
if pos('(', s) > 0 | length(s) > 20 then
return "fImm('F_GEN."fCache('%t'cd, '%t'cd)"'," s")"
if c == ' ' then do
if pos(d, 'SN') > 0 then
o = "Ndate('S') time('L')"
else if pos(d, 'sMAn ') > 0 then
o = "ndate('S') time()"
else if pos(d, 'DdEeY') > 0 then
o = "Ddate('S')"
else if pos(d, 'tH') > 0 then
o = "ttime('')"
else if pos(d, 'T') > 0 then
o = "Ttime('L')"
else
call err 'fTstGen implement d='d
parse var o o1 2 o2
return "fImm('F_GEN."fCache('%t'o1 || d, '%t'o1 || d)"',"o2")"
end
f = m.f_tstFo.c
if d = ' ' then
d = 's'
t = m.f_tstFo.d
if f == t then
return s
r = "translate("quote(t, "'")"," s "," quote(f, "'")")"
if pos('yz34', t) > 0 & pos('yz34', f) < 1 then do
if pos('34', f) > 0 then
r = "overlay('20'," r"," pos('yz', t)")"
else if pos('Y', f) > 0 then
r = fTstGY2Year(r, "substr("s"," pos('Y', f)", 1)", 4,
, pos('yz34', t))
else
r = "overlay('0000'," r"," pos('yz34', t)")"
end
else if pos('34', t) > 0 & pos('34', f) < 1 then do
if pos('Y', f) > 0 then
r = fTstGY2Year(r, "substr("s"," pos('Y', f)", 1)", 2,
, pos('34', t))
else
r = "overlay('00'," r"," pos('34', t)")"
end
if pos('Y', t) > 0 & pos('Y', f) < 1 then do
if pos('yz34', f) > 0 then
r = fTstGYear2Y(r, "substr("s"," pos('yz34', f)", 4)" ,
, pos('Y', t))
else if pos('34', f) > 0 then
r = fTstGYear2Y(r, "substr("s"," pos('34', f)", 2)" ,
, pos('Y', t))
else
r = "overlay('?'," r"," pos('Y', t)")"
end
if pos('M', t) > 0 & pos('M', f) < 1 then do
if pos('56', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('56', f)", 2)" ,
, pos('M', t))
else
r = "overlay('?'," r"," pos('M', t)")"
end
if pos('56', t) > 0 & pos('56', f) < 1 then
if pos('M', f) > 0 then
r = fTstGA2N2(r, "substr("s"," pos('M', f)", 1)" , "-1",
, pos('56', t))
else
r = "overlay('01'," r"," pos('56', t)")"
if pos('78', t) > 0 & pos('78', f) < 1 then
r = "overlay('01'," r"," pos('78', t)")"
if pos('A8', t) > 0 & pos('A8', f) < 1 then
if pos('78', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('78', f)", 1)" ,
, pos('A8', t))
else
r = "overlay('A1'," r"," pos('A8', t)")"
if pos('hi', t) > 0 & pos('hi', f) < 1 then do
if pos('H', f) > 0 then
r = fTstGA2N1(r, "substr("s"," pos('H', f)", 1)" , "-1",
, pos('hi', t))
else
r = "overlay('00'," r"," pos('hi', t)")"
end
if pos('i', t) > 0 & pos('i', f) < 1 then
r = "overlay('0'," r"," pos('i', t)")"
if pos('H', t) > 0 & pos('H', f) < 1 then do
if pos('hi', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('hi', f)", 1)" ,
, pos('H', t))
else
r = "overlay('A'," r"," pos('H', t)")"
end
if pos('mn', t) > 0 & pos('mn', f) < 1 then
r = "overlay('00'," r"," pos('mn', t)")"
if pos('st', t) > 0 then do
if pos('st', f) < 1 then
if pos('s', f) > 0 then
r = "overlay('0'," r"," pos('t', t)")"
else
r = "overlay('00'," r"," pos('st', t)")"
end
else if pos('s', t) > 0 & pos('s', f) < 1 then
r = "overlay('0'," r"," pos('s', t)")"
if pos('abcdef', t) > 0 & pos('abcdef', f) < 1 then
r = "overlay('000000'," r"," pos('abcdef', t)")"
return r
endProcedure fTstGen
/*--- from Number overlay Character A=0, B=1 etc.. ------------------*/
fTstG02A: procedure expose m.
parse arg r, n, tx
return "overlay(substr(m.ut_alfUc," n "+ 1, 1)," r"," tx")"
/*--- from year overlay Y-Character A=2010 etc..--------------------*/
fTstGYear2Y: procedure expose m.
parse arg r, y, tx
return fTstG02A(r, "("y "+ 10) // 20", tx)
/*--- from character A=0 overlay 1 digit number ---------------------*/
fTstGA2N1: procedure expose m.
parse arg r, y, dlt, tx
return "overlay(right(pos("y", m.ut_alfUc)" dlt", 1)," r"," tx")"
/*--- from character A=0 overlay 2 digit number ---------------------*/
fTstGA2N2: procedure expose m.
parse arg r, y, dlt, tx
return "overlay(right('00' || (pos("y", m.ut_alfUc)" dlt"), 2)",
"," r"," tx")"
/*--- from Y yearCharacter overlay 2 or 4 digit year ----------------*/
fTstGY2Year: procedure expose m.
parse arg r, y, len, tx
if m.f_tstY2ini \== 1 then do /* generate lookup table */
m.f_tstY2ini = 1
n = left(f('%t '), 4)
do i = n-15 to n+4 /* 20 values: from -15 years to + 4 */
j = left(f('%tDY', i'0101'), 1)
m.f_tstY24.j = i
m.f_tstY22.j = right(i, 2)
/* say j m.f_tstY22.j m.f_tstY24.j */
end
end
if wordPos(len, 2 4) < 1 then
call err "fTstGYear2Y bad len" len
return "overlay(mGet('F_TSTY2"len".'"y")," r"," tx")"
endProcedure fTstGY2Year
/* copy f 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
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return 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 ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
/* copy tstAll begin *************************************************/
/*----------- 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_alfLC)
c1 = substr(m.ut_alfLC, cx, 1)
abc = abc '[[#'c1 '|' c1']]'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('[=', li)
if bx < 1 then
leave
ex = pos('=]', li)
if ex <= bx then
call err '=] before [= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '[[#'w']] {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '[')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, ']:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== ']')
hasBr = substr(li, cx, 1) == '['
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == ']' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< [['w']]'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '[[Lit'translate(t1)':'word(dN, tx) '|' t1 ']]'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then do
call tstZos
call tstTut0
end
return 0
endProcedure tstAll
/****** tstZos ********************************************************/
tstZOs:
call tstTime
call tstII
call sqlIni
call tstSqlRx
call tstSql
call tstSqlCsm
call scanIni
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstsql4obj
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
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
/****** 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
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
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 ###############################################
iiRz2C(RZ2) 2
*** err: no rz=R?Y in ii II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no dbSys=D??? in ii II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZ1 RZ2 RR2 RZ4 RZX RZY RZZ
ii_dbSys.rzx DE0G DEVG DPXG DX0G
$/tstII/
*/
call tst t, 'tstII'
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_dbSys.rzx ' m.ii_dbSys.rzx
call tstEnd t
return
endProcedure tstII
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.55.789008
Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs
timeZone 7200.00000 leapSecs 25.0000000
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.55.789008
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D6CFDD13C
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741)( C5E963363741
$/tstTime/
*/
call jIni
call tst t, 'tstTime'
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out ,
'Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs'
call out 'timeZone' m.timeZone * m.timeStckUnit ,
'leapSecs' m.timeLeap * m.timeStckUnit
call timeReadCvt 1
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
call out 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
call tstEnd t
return
endProcedure tstTime
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
/****** tstSql ********************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St '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
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 tst t, "tstSqlRx"
call sqlRxConnect
cx = 7
call sqlRxQuery cx, 'select * from sysdummy'
call sqlRxQuery 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' sqlRxFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlRxClose 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 sqlRxQuery 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' sqlRxFetch(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 sqlRxClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlRxQuery 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' sqlRxFetch(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 sqlRxClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrep cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryArgs cx, 'SYSTABLES'
call out 'fetchBT' sqlRxFetch(cx) m.nm
call out 'fetchBT' sqlRxFetch(cx) m.nm
call sqlRxClose cx
call sqlQueryArgs cx, 'SYSINDEXES'
call out 'fetchBi' sqlRxFetch(cx) m.nm
call out 'fetchBi' sqlRxFetch(cx) m.nm
call tstEnd t
call sqlRxDisconnect
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 tst t, "tstSql"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, '?ab cd ?ef ?gh'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrep cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryArgs cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryArgs cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
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: subsys = DE0G, host = RZZ
*** err: fetchVars with : for csm: :m.dst.ab, :m.dst.ef
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchB 1 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchB 0 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
$/tstSqlCsm/ */
call tst t, "tstSqlCsm"
call sqlConnect 'RZZ/DE0G'
cx = 7
call sqlCsmQuery cx, 'select * from sysdummy'
call sqlCsmQuery 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' sqlCsmFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
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"
call sqlCsmQuery 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' sqlCsmFetch(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
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlCsmQuery 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' sqlCsmFetch(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
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
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 csvIni
call scanReadIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csvWrt(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 tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx
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+
OPYUP-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN---SP+
ACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-REORG+
SC-REORGHA-HASHLASTUS-DRI-L-STATS01----
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUP-COPYUPDATETIME-------------I-+
--DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REORG+
HA-HASHLASTUS-DRI-L-STATS01----
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-COPYUP-COPYUPDATETIME-------------I-+
--DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REORG+
HA-HASHLASTUS-DRI-L-STATS01----
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REORGSC+
ANACCESS DRIVETYPE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASIZE +
. REORGHASHACCESS LPFACILITY
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTERSEN+
S HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabReset abc, 17, 1, , 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabReset abc, 17, 2 1, 1 3 'c', 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
call fTabAddTit abc, 2, 'others vorher'
call fTabAddTit abc, 3, 'others nachher'
call sqlFTabOthers abc
call sqlFTab abc
call sqlClose 17
call tstEnd t
return
endProcedure tstSqlFTab
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
i = inO()
if i == '' then
leave
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call outO i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
call sqlIni
/*
$=/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 s9 into :M.SQL.9.D from :src
. e 7: with into :M.SQL.9.D = M.SQL.9.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s9 into :M.SQL.9.D from :src
. e 3: with into :M.SQL.9.D = M.SQL.9.D
sys ==> 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: subsys = DE0G, host = RZZ
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: subsys = DE0G, host = RZZ
sys RZZ/DE0G ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2 .
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sqlBuf = jBuf("select 1 i1, 'eins' c2 from sysibm.sysDummy1",
, "union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1")
do tx=1 to 2
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
end
else do
call tst t, "tstSqlCCsm"
sys = 'RZZ/DE0G'
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fTabAuto , sqlRdr(sqlBuf)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdPrep 5, "insert into session.dgtt values (?, ?, ?)"
call sqlUpdArgs 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdArgs 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdPrep 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdArgs 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrep cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad' ,
'from session.dgtt d'
call sqlQueryArgs 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 sqlQueryPrep cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryArgs 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 tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlRxConnect
call sqlRxUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlRxUpdate,"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 sqlRxQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlRxFetch(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 sqlRxClose cx
call sqlRxQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlRxFetch(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 sqlRxClose cx
call sqlRxDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call tst t, "tstSqlO"
call sqlStmt 'set current schema = A540769';
call sqlStmt '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 assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call 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 tst t, "tstSqlUpdComLoop"
call sqlConnect
call out sqlStmt("declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows")
call out sqlStmt("insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only")
call out sqlStmt("select count(*) cnt from session.dgtt")
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call out sqlStmt("select count(*) cnt from session.dgtt")
call 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 sqlConnect
call tst t, "tstSqlO1"
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 assNN('ABC', jReadO(qr))
if m.qr.rowCount = 1 then do
cx = m.qr.cursor
end
call outO abc
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlConnect
call tst t, "tstSqlO2"
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlIni
call tst t, "tstSqlS1"
call sqlConnect
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: 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
call tst t, "tstSqlStmt"
cn = className(classNew('n* SQL u f C v'))
call mAdd t.trans, cn '<sql?sc>'
call tstOut t, sqlStmt("set current schema = 'sysibm'")
call tstOut t, sqlStmt(" set current schema = sysibm ")
call tstOut t, sqlStmt(" select current schema c from sysDummy1",
, ,'o')
call tstOut t, sqlStmt(" (select current schema c from sysDummy1)",
, ,'o')
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: 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;
sqlCode 0: set current schema = s100447
#jIn eof 3#
$/tstSqlStmts/ */
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b, , '-sql72'
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
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
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, DB2PDB6,RR2HHAGE)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE, 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
/****** 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 tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompTable
call tstCompSyntax
if m.err.os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.err.count = oldErr
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-[2*3$] "efg"$-[2*3$]"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-[2*3$] "efg"$-[2*3$]"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-[ix+1$] "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-[ix+1$] "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-[2*3$] efg$-[2*3$]hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@[ $$ do j=$j
run without input
do j=0
after if 0 $@[ $]
after if 0 $=@[ $]
do j=1
if 1 then $@[ a
a2
if 1 then $@=[ b
b2
after if 1 $@[ $]
after if 1 $=@[ $]
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@[ $$ do j=$j' ,
, 'if $j then $@[ ',
, '$$ if $j then $"$@[" a $$a2' ,
, '$]',
, 'if $j then $@=[ ',
, '$$ if $j then $"$@=[" b $$b2' ,
, '$]',
, 'if $j then $@[ $]' ,
, '$$ after if $j $"$@[ $]"' ,
, 'if $j then $@=[ $]' ,
, '$$ after if $j $"$=@[ $]"' ,
, '$]',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-[ 3 * 5 $] = 15
rexx $-[ 5 * 7 $] = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-[4*5$] $-[efg$-[6*7$] abc20 EFG42
brackets $-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$] 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-[ 3 * 5 $] = 15
rexx $-[ 5 * 7 $] = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-[4*5$] $-[efg$-[6*7$] abc20 EFG42
brackets $-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$] 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-[ 3 * 5 $] =" $-[ 3 * 5 $]' ,
, 'rexx $"$-[ 5 * 7 $] =" $-[ 5 * 7 $]' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=[ line three',
, 'line four $] bis hier' ,
, 'shell $-@[ $$ line five',
, '$$ line six $] bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-[4*5$] $-[efg$-[6*7$]"',
'abc$-[4*5$] $-[efg$-[6*7$]$]',
, 'brackets $"$-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$]"',
'$-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$]'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.vv)="o2String($.vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"]vv="', '$vv',
, '$"s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.vv= ]vvDat
$.-["abc"$]=]abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.vv=" $.vv',
, '$"$.-[""abc""$]="$.-["abc"$]'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.vv)="o2string($.vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call vPutO '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 vPutO 'vA', v1
call vPutO 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@[' stmt ,
, '$@with $vB ' stmt stmt '$]'
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
*** err: no class found for object 0
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary not finished
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- [ .
*** err: scanErr primary not finished
. e 1: last token scanPosition [
. e 2: pos 5 in line 1: b $- [
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- [ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f 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 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### 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
$/tstCompSynAss5/ */
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 10 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 rexxShell expected: compile @ stopped before end o+
f 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 rexxShell expected: compile @ stopped before end o+
f 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 rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@: und
. e 2: pos 1 in line 1: $@: und
*** err: no class found for object 0
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr var or namedBlock expected after proc
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% [roc p1$]
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f 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: pos 18 in 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 18 in line 1: $@^[call( $** roc
$/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 outO m.tstComp.4 $]',
, '$$ out .$"$.@[$$abc $$efg$]" $$.$.@@[ $$abc ', ' ', ' $$efg $]',
, '$$ out .$"$.@[o5$]" $$.$.@@[ $$.m.tstComp.5', '$$abc $]'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.[o1]" $$.<.[ m.tstComp.1 $]
run without input
out ..<.[o1]
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@[$$abc $$efg$]
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.[o1]" $$.<.[ m.tstComp.1 $]',
, '$$ out .$"<$.-{o2}" $$<.[ m.tstComp.2 $]',
, '$$ out .$"$.<{o3}" $$<=[ m.tstComp.3 $]',
, '$$ out .$"$.<@{out o4}" $$<@[ call outO m.tstComp.4 $]',
, '$$ out .$"$<@[$$abc $$efg$]" $$<@[ $$abc ', ' ', ' $$efg $]'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith 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 vPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%[oRun$]' ,
, ' $@%[oRun $"-{1 arg only}" oder?$]' ,
, ' $@%-[oRun $.".{1 obj only}" ''oder?''$] $=v2=zwei' ,
, ' $@%-[oRun $"{2 args}", "und" $v2"?"$]' ,
, ' $@%-[oRun $"{3 args}", $v2, "und drei?"$]'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata [ .
heredata 1 xValue
heredata 2 yValueY
nach heredata [
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata [ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata [',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=[$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call 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 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@[ $@for vv $$ <$vv> $] ',
, ' $$ output eins $-=[$eins$]$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-[ $dsn $] 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=[$@<dsn$] '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =.$.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =.$.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^[compile =$] +
$<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^[compile =$] $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-[
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $]
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.$pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.$pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '=/vD/valueVonD',
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@[ $$ vF=$vF$]' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:[ix=- $ix+1' ,
, ' $$ for $ix -> $v' ,
, '] | @[call pipePreSuf "<<",">>"',
, '$] @%[p1 total $ix im argumentchen$]',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:[tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '] $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompTable: procedure expose m.
/*
$=/tstCompTable1/
### start tst tstCompTable1 #######################################
compile :, 6 lines: table $*( sdf $*) .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = v1
tstR: .fZwei = valueZwei
tstR: .fDrei = undDrei
zweite
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = w1
tstR: .fZwei = wZwei
tstR: .fDrei = wwwDrei
$/tstCompTable1/
*/
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
call tstComp1 ': tstCompTable1',
, 'table $*( sdf $*) ' ,
, 'fEins fZwei $*(....$*) fDrei ' ,
, '$@[call mAdd t.trans, className("'cl'") "<TstCT1Class>"$]',
, ' v1 valueZwei undDrei ' ,
, '$$ zweite',
, ' w1 wZwei wwwDrei '
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew nn $*( sdf $*) $@:[ .
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: @tstWriteoV4 isA :<TstCT1Class>
tstR: .fEins = withValue fEinsC
tstR: .fZwei = .
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call tstComp1 ': tstCompWithNew',
, 'withNew nn $*( sdf $*) $@:[ ' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@[call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:[ fDrei = withNewValuel drei $] $]] $$ $.nn' ,
, 'withNew out $*( sdf $*) $@:[ ' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, '] with out =. oNew('cl') $@:[',
, 'fEins = withValue fEinsC' ,
, 'fDrei = withValue fDreiC $]'
return
endProcedure tstCompTable
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=[
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$]
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=[
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
call sqlDisConnect
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=[ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-[sysvar(sysnode) date() time()?]ts=$ts 10*len=$-[length($ts)*10$]
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@[if right($ts, 2) == '7A' then $@=[
FULL YES
$] else
$$ $'' FULL NO
$]
SHRLEVEL CHANGE
$*+] Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-[sysvar(sysnode) date() time()?]ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@[
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=[
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$**]
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$@:[table
db ts
DGDB9998 A976
DA540769 A977
$]
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=[
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=[ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$]
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=[
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:[withNew out :[
db = DGDB9998
ts =<:[table
ts
A976
A977
$]
db = DA540769
<|/ts/
ts
A976
A975
/ts/
]
$** $$. $lst
$** $@ct $@[$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$]
$** $@$tool
$@do sx=1 to ${lst.0} $@[
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=[
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@[ say $-=[subsys $subsys db $db ts $ts $] $]
$@copy()
$]
$]
$@ct $@[
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$]
$@proc copy $@=[
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:[table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$]
$| $@=[
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=[
$co '$ts'
$=co=,
$]
)
$]
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=[
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$]
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err.os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase ********************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstClass3
call scanIni
call tstO
call classIni
call tstF
call tstFtst
call tstMCat
call tstOEins
call jIni
call tstJSay
call tstJ
call tstJ2
call tstJCatSql
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstFE
call tstFTab
call tstFmt
call tstfUnits
call tstCsv
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 while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMCat: procedure expose m.
/*
$=/tstMCat/
### start tst tstMCat #############################################
mCat(0, ) =;
mCat(0, 1) =;
mCat(0, 112222%,%,%,11) =;
mCat(0, 231%,%c%,1%,2) =;
mCat(0, 33341%,%c2@%c%,1%,333)=;
mCat(0, 45%,1%c2@%c3@%c%,%,4) =;
mCat(1, ) =eins;
mCat(1, 1) =eins;
mCat(1, 112222%,%,%,11) =eins11;
mCat(1, 231%,%c%,1%,2) =1eins2;
mCat(1, 33341%,%c2@%c%,1%,333)=1eins2eins333;
mCat(1, 45%,1%c2@%c3@%c%,%,4) =1eins2eins3eins4;
mCat(2, ) =einszwei;
mCat(2, 1) =eins1zwei;
mCat(2, 112222%,%,%,11) =eins112222zwei11;
mCat(2, 231%,%c%,1%,2) =1eins231zwei2;
mCat(2, 33341%,%c2@%c%,1%,333)=1eins2eins33341zwei2zwei333;
mCat(2, 45%,1%c2@%c3@%c%,%,4) =1eins2eins3eins451zwei2zwei3zwei4;
mCat(3, ) =einszweidrei;
mCat(3, 1) =eins1zwei1drei;
mCat(3, 112222%,%,%,11) =eins112222zwei112222drei11;
mCat(3, 231%,%c%,1%,2) =1eins231zwei231drei2;
mCat(3, 33341%,%c2@%c%,1%,333)=1eins2eins33341zwei2zwei33341drei2dr+
ei333;
mCat(3, 45%,1%c2@%c3@%c%,%,4) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstMCat/ */
call mIni
call tst t, "tstMCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstMCat1 qx
call tstMCat1 qx, '1'
call tstMCat1 qx, '112222%,%,%,11'
call tstMCat1 qx, '231%,%c%,1%,2'
call tstMCat1 qx, '33341%,%c2@%c%,1%,333'
call tstMCat1 qx, '45%,1%c2@%c3@%c%,%,4'
end
call tstEnd t
return
endProcedure tstMCat
tstMCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("mCat("m.qq.0"," fmt")", 30)"="mCat(qq, fmt)";"
return
endProcedure tstMCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.10 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.4 :class = u
. choice u union
. .NAME = v
. stem 3
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = oCopy
. .MET = return oCopyV(m, t)
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. stem 0
. .3 refTo @CLASS.3 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.13 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.12 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.11 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.14 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.12 done :class @CLASS.12
. .4 refTo @CLASS.16 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.15 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.17 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.12 done :class @CLASS.12
. .6 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.21 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.20 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.11 done :class @CLASS.11
. .2 refTo @CLASS.19 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.4 done :class @CLASS.4
. .8 refTo @CLASS.23 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.22 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
$/tstClass2/
$=/tstClass2oo/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.108 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2oo/ */
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
met class#oCopy return classCopy('<class class>', m, t)
t1 4 flds 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 flds , 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 flds M.<class tst...Tf33>.FLDS.1, M.<class tst...Tf33>.FLDS.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
m.o_escW = ']'
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')
call tstOut t, 'met class#oCopy' classMet(m.class_C, 'oCopy')
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 = classFlds(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'flds' 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)
*** err: missing key in mapGet(CLASS_N2C, 0)
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.8
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.8
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: missing key in mapGet(CLASS_N2C, 0)'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call 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
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class ---
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new return classClear('<class T..1>', oMutate(mNew('<class T..1>+
'), '<class T..1>'))
$/tstO/
*/
call mIni
call tst t, 'tstO'
call classIni
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 class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class 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 scanIni
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
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay.jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call 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 jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Af', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
[7 +6 nach pipe 7]
[7 +2 nach pipe 7]
[7 +4 nach nested pipeLast 7]
[7 (4 +3 nach nested pipeBegin 4) 7]
[7 (4 (3 +1 nach pipeBegin 3) 4) 7]
[7 (4 (3 tst in line 1 eins , 3) 4) 7]
[7 (4 (3 tst in line 2 zwei ; 3) 4) 7]
[7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7]
[7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7]
[7 (4 +3 nach preSuf vor nested pipeLast 4) 7]
[7 +4 nach preSuf vor nested pipeEnd 7]
[7 +5 nach nested pipeEnd vor pipe 7]
[7 +6 nach writeNow vor pipeLast 7]
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '[7 ', ' 7]'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 's',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
v1=value eins o=TST.ADR1
v3=v3WieGehts? o=]v3WieGehts?
v4=v4WieGehts? o=]v4WieGehts?
o o0=<o0>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
o o0=<o0>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
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>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
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>
*** err: no method o2String in class TstEnvVars1
*** err: o2String did not return
o o1=<o1> s o1=0
o1&fStr=put-o1.fStr o=]put-o1.fStr
o1&=put-o1-value o=]put-o1-value
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
o1&fRef=0 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
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
o2&fRef&fRef=0 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>
oS&0=9876 .12=M.<oS>.12 .1234=<put oS.1234>
$/tstEnvVarsS/
*/
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')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPutO('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 vPutO 'theBuf', jBuf()
call pipe '+F' , vGetO('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGetO('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGetO('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGetO('v3')
call vPutO 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGetO('v4')
call vPutO 'o0', o0
call tstOut t, 'o o0='vGetO('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='vGetO('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGetO('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGetO('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&') 'o='vGetO('o0&')
call vPut 'o0&', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPutO 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGetO('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGetO('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGetO('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&') 'o='vGetO('o0&')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPutO 'o1', o1
call vPut 'o1&', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPutO 'o1&fRef', vGetO('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='vGetO('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGetO('o1&fStr')
call tstOut t, 'o1&='vGet('o1&') 'o='vGetO('o1&')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGetO('o1&fRef')
call tstOut t, 'o1&fRef&fSt0='vGet('o1&fRef&fSt0') ,
'o='vGetO('o1&fRef&fSt0')
call tstOut t, 'o1&fRef&fRe0='vGet('o1&fRef&fRe0'),
'o='vGetO('o1&fRef&fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPutO '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='vGetO('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGetO('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPutO 'o2', o2
call vPutO 'o2&fRef', vGetO('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGetO('o2'),
'getO(o2&fRef)='vGetO('o2&fRef')
call tstOut t, 'o2&fRef&fStr='vGet('o2&fRef&fStr'),
'o='vGetO('o2&fRef&fStr')
call tstOut t, 'o2&fRef&='vGet('o2&fRef&'),
'o='vGetO('o2&fRef&')
call tstOut t, 'o2&fRef&fRef='vGet('o2&fRef&fRef') ,
'o='vGetO('o2&fRef&fRef')
call tstOut t, 'o2&fRef&fRef&fSt0='vGet('o2&fRef&fRef&fSt0') ,
'o='vGetO('o2&fRef&fRef&fSt0')
call tstOut t, 'o2&fRef&fRef&fRe0='vGet('o2&fRef&fRef&fRe0'),
'o='vGetO('o2&fRef&fRef&fRe0')
call tstOut t, 'o2&fRef&fNest.fSt0='vGet('o2&fRef&fNest.fSt0'),
'o='vGetO('o2&fRef&fNest.fSt0')
call tstOut t, 'o2&fRef&fNest&fRe0='vGet('o2&fRef&fNest.fRe0'),
'o='vGetO('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 vPutO '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='vGetO('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
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: missing key in mapGet(V, F1)
*** err: no class found for object 0
*** err: o2String did not return
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3.FDREI 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: missing key in mapGet(V, F1)
*** err: no class found for object 0
*** err: o2String did not return
po-1 F1 0
$/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 vPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGetO('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 ' vGetO('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 ' vGetO('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 ' vGetO('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: vAdrObj undef v(c3&f1) in name .F1&FEINS
*** err: vGet flag 0
. s c3&F1&FEINS = 0
*** err: vAdrObj null at .F3& in name .F3&FEINS
*** err: vGet flag 0
. s c3&F3&FEINS = 0
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: vAdrStem no stem cl TstEW, o <c3>, f .FEINS
*** err: vAdrStem not a stem cl=TstEW st= o=<c3>
*** err: vGet flag 0
. s c3&FEINS = 0
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: missing key in mapGet(V, F1)
*** err: no class found for object 0
*** err: o2String did not return
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPutO '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&', vGetO('c3&')
call vPutO '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 = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+f', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstMail: procedure expose m.
do i=1 to 3
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mAdd 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 ,
, left('und eine lange Zeile ', 200, '+')203 'y ',
, 'und kurz' ,
, 'und Schluss'
call mailSend xy
call sleep 60
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call out "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call out 'tstF2' fmt '-----'
do vx=1 to words(vals)
call out f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SY => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sY => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
$/tstFTsts/
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DY => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
$/tstFTstD/
0----+----1----+----2----+----3
abcdefghijklmnopqrstuvwxyz
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dY => CH24|
120724 dM => H2400000|
120724 dH => A00000|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EY => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.2467 eS => 2024-05-31-00.00.00.000000|
31.05.2467 es => 2024-05-31-00.00.00|
31.05.2467 e => 2024-05-31-00.00.00|
31.05.2467 eD => 20240531|
31.05.2467 ed => 240531|
31.05.2467 eE => 31.05.2024|
31.05.2467 ee => 31.05.2467|
31.05.2467 et => 00.00.00|
31.05.2467 eT => 00:00:00.000000|
31.05.2467 eY => OF31|
31.05.2467 eM => F3100000|
31.05.2467 eH => A00000|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0000-01-01-12.34.56.000000|
12.34.56 ts => 0000-01-01-12.34.56|
12.34.56 t => 0000-01-01-12.34.56|
12.34.56 tD => 00000101|
12.34.56 td => 000101|
12.34.56 tE => 01.01.0000|
12.34.56 te => 01.01.00|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tY => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0000-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0000-01-01-23.45.06|
23.45.06.784019 T => 0000-01-01-23.45.06|
23.45.06.784019 TD => 00000101|
23.45.06.784019 Td => 000101|
23.45.06.784019 TE => 01.01.0000|
23.45.06.784019 Te => 01.01.00|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TY => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
$/tstFTstT/
$=/tstFTstY/
### start tst tstFTstY ############################################
FE25 YS => 2015-04-25-00.00.00.000000|
FE25 Ys => 2015-04-25-00.00.00|
FE25 Y => 2015-04-25-00.00.00|
FE25 YD => 20150425|
FE25 Yd => 150425|
FE25 YE => 25.04.2015|
FE25 Ye => 25.04.15|
FE25 Yt => 00.00.00|
FE25 YT => 00:00:00.000000|
FE25 YY => FE25|
FE25 YM => E2500000|
FE25 YH => A00000|
$/tstFTstY/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0000-08-23-17.49.50.000000|
I2317495 Ms => 0000-08-23-17.49.50|
I2317495 M => 0000-08-23-17.49.50|
I2317495 MD => 00000823|
I2317495 Md => 000823|
I2317495 ME => 23.08.0000|
I2317495 Me => 23.08.00|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MY => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0000-01-01-12.34.56.000000|
B23456 Hs => 0000-01-01-12.34.56|
B23456 H => 0000-01-01-12.34.56|
B23456 HD => 00000101|
B23456 Hd => 000101|
B23456 HE => 01.01.0000|
B23456 He => 01.01.00|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HY => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nY => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32102130 10:21:32.456789 NS => 3210-21-30-10.21.32.456789|
32102130 10:21:32.456789 Ns => 3210-21-30-10.21.32|
32102130 10:21:32.456789 N => 3210-21-30-10.21.32|
32102130 10:21:32.456789 ND => 32102130|
32102130 10:21:32.456789 Nd => 102130|
32102130 10:21:32.456789 NE => 30.21.3210|
32102130 10:21:32.456789 Ne => 30.21.10|
32102130 10:21:32.456789 Nt => 10.21.32|
32102130 10:21:32.456789 NT => 10:21:32.456789|
32102130 10:21:32.456789 NY => AV30|
32102130 10:21:32.456789 NM => V3010213|
32102130 10:21:32.456789 NH => B02132|
$/tstFTstN/
*/
call scanIni
say "f('%t ')" f('%t ')
allOut = 'Ss DdEetTYMH'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.2467' ,
't12.34.56' ,
'T23.45.06.784019' ,
'YFE25' ,
'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32102130*10:21:32.456789'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
call tstEnd t
end
return
endProcedure tstFTst
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
call fTabAddDetect abc, , st , 'c3L'
call fTabAdd abc, 'a2i', ' % 8E'
call fTabAddDetect abc, 'b3b', st , 'drei'
call fTabAdd abc, 'd4', ' %-7C'
call fTabAddDetect abc, 'fl5', st
call fTabAddDetect abc, 'ex6', st
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
call pipeIni
call scanIni
/*
$=/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 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
/*
$=/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, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstfUnits: procedure
/*
$=/tstfUnits/
### start tst tstfUnits ###########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstfUnits/ */
call jIni
call tst t, "tstfUnits"
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) ,
'==>' fTime( word(lst, wx) ) ,
'++>' fTime( word(lst, wx), 1),
'-+>' fTime('-'word(lst, wx), ),
'-->' fTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fDec( word(lst, wx) ) ,
'++>' fDec( word(lst, wx), 1),
'-+>' fDec('-'word(lst, wx), ),
'-->' fDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 .
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 cd) ) gh) .
$/tstSb/ */
call tst t, 'tstSb'
call scanSBSrc s, 'abcdefghijklkl ?'
call out 'end :' scanSBEnd(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 :' scanSBEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanSBEnd(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 scanSBSrc 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 scanSBSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSBSrc 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 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 cd) ) gh) .
$/tstSb2/ */
call tst t, 'tstSb2'
call scanIni
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 scanIni
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 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 1: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 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;+-=f ab=cdEf eF='strIng' .
scan b tok 1: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanOpen(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 scanClose 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(scanRead(jClose(b)), '<')
do x=1 while ass('v', jReadO(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
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(scanUtilReset(ScanRead(b)), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition 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(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
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
/*
$=/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
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \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
return
endProcedure tstScanWin
tstjCatSql: procedure expose m.
/*
$=/tstJCatSql/
### start tst tstJCatSql ##########################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 .
$/tstJCatSql/ */
call tst t, 'tstJCatSql'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ')
call jCatSqlReset tstJCat, , jOpen(b, '<'), 30
do sx=1 until nx = ''
nx = jCatSqlNext(tstJCat, ';')
call tstOut t, 'cmd'sx nx
end
call jClose b
call tstEnd t
return
endProcedure tstJCatSql
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \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 = jOpen(scanSql(b), m.j.cRead)
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 = jOpen(scanSql(b), m.j.cRead)
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 = jOpen(scanSql(b), m.j.cRead)
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 scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \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
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanOpts(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
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
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/****** tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
call scanIni
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 = oFlds(fo)
do fx=1 to m.ff.0
f = fo || left('.', m.ff.fx \== '') || 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 = oFlds(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || left('.', m.ff.fx \== '') || m.ff.fx
m.f = tstData(m.f, m.ff.fx, '+'m.ff.fx'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/****** tst **********************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
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
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.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
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
m.tst_m = m
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
drop m.tst_m
call oMutatName m, 'Tst'
call oMutatName m'.IN', 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
m.m.in.jReading = 1
m.m.in.jWriting = 1
m.m.in.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
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 ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
cl = objClass(var, '')
if cl == '' then do
if var == '' then
call tstOut t, 'tstR: @ obj null'
else
call tstOut t, 'no class for' var 'in tstWriteO|'
end
else if abbrev(var, m.o_escW) then do
call tstOut t, o2String(var)
end
else if cl == m.class_V then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
if right(m, 3) == '.IN' then
m = left(m, length(m)-3)
else
call err 'tstReadO bad m' m
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call errMsg ' }'ggTxt
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copy tstAll end **************************************************/