zOs/REXX/TX
/* rexx ****************************************************************
tx: testDriver
as editMacro: tx fun
from tso: tx pdsMbr fun
fun = empty execute unprocessed statements
r clear process flags and execute from beginning
c clear process flags
version from 11.11.16
***********************************************************************/
call errReset 'hI'
call wshIni
m.sql_retOK = 'dne rod'
parse arg oArgs
args = oArgs
if 0 then
oArgs = 'L DSN.MAREC.DBZF.D090702.T175332.JOB101(STAALL)' ,
'001 YMRCO001 rebu wa'
m.dbConn = ''
m.tx_ini = 0
m.tx.isMacro = oArgs == '' & sysVar('sysISPF') = 'ACTIVE'
if m.tx.isMacro then
m.tx.isMacro = adrEdit('macro (oArgs)', '*') == 0
if m.tx.isMacro then do
call adrEdit '(pds) = dataset'
call adrEdit '(mbr) = member'
parse var oArgs o1 o2
if length(o1) > 8 then do
m.tx.isMacro = 0
end
else if length(o1) > 2 then do
args = pds'('o1')' o2
m.tx.isMacro = 0
end
else do
if mbr == '' then
call err 'edit a pds member not' pds
args = pds'('mbr')' oArgs
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call err 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' pds'('mbr')'
call adrEdit 'save', '*'
end
end
end
if args = '' | pos('?', args) > 0 then
exit help()
parse var args dsn fun opts
dsn = dsn2jcl(dsn)
call vPut 'dsn', dsn
call vPut 'pds', dsnSetMbr(dsn)
mbr = dsnGetMbr(dsn)
if mbr = '' | length(mbr) > 7 then
call errHelp 'first arg word not a pds with member <=7:' args
call vPut 'mbr', mbr
call vPut 'mpr', if(length(mbr) <= 5, mbr, left(mbr, 5))
call vPut 'ini', dsnSetMbr(dsn, 'INI')
call vPut 'gen', ''
if abbrev(fun, '-') then do
opts = substr(fun, 2) opts
fun = ''
end
ib = jBuf()
m.tx.inp = ib
m.tx.iBuf = ib'.BUF'
call readDsn dsn, 'M.'m.tx.iBuf'.'
m.tx.comp = comp(ib)
m.tx.save = 0
m.tx.outAdd.0 = 0
if fun = '' then do
call txCont opts
end
else if fun = 'c' then do
call txReset m.tx.iBuf, opts
end
else if fun = 'r' then do
call txReset m.tx.iBuf, opts
call txSave
call readDsn dsn, 'M.'m.tx.iBuf'.'
call txCont opts
end
else
call errHelp 'bad fun' fun 'in args' oArgs
call txSave
call dbConn
exit
dbConn: procedure expose m.
parse arg sub
if m.dbConn = sub then
return
if m.dbConn \== '' then
call sqlDisconnect
if sub \== '' then
call sqlConnect sub
m.dbConn = sub
say 'connected to' sub
return
endProcedure dbConn
sqlProc: procedure expose m.
parse arg inp, pJ72
say sqlProc 'j72' pJ72
call sqlStmts inp, 100, if(pJ72==1, 's')
return
endProcedure sqlProc
txCmpRun: procedure expose m.
parse arg ki, inpDsn, outDsn
say 'txCmpRun' inpDsn '->' outDsn / 0
call compRun ki, file(inpDsn), file(outDsn)
say 'txCmpRun -> ended'
return
endProcedure txCmpRun
/*--- remove all history information from testcase,
so it will restart from scratch next time --------------------*/
txReset: procedure expose m.
parse arg i
z = 0
do y=1 to m.i.0
if pos(firstNE(m.i.y), '-+') > 0 then
iterate
z = z + 1
m.i.z = m.i.y
end
m.tx.save = z \= m.i.0
m.i.0 = z
return
endProcedure txReset
/*--- save testcase member if necessary ------------------------------*/
txSave: procedure expose m.
if m.tx.save = 0 then
return
ib = m.tx.iBuf
if m.tx.save = 1 then do
if \ m.tx.isMacro then do
call writeDsn vGet('dsn'), 'M.'ib'.', , 1
return
end
call adrEdit 'del .zf .zl'
do y=1 to m.ib.0
li = m.ib.y
call adrEdit 'line_after .zl = (li)'
end
call adrEdit 'save'
end
else if m.tx.save = 2 then do
ox = 0
ix = 0
if m.tx.isMacro then do
added = 0
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
call adrEdit 'line_after' (added+ax) '= (li)'
added = added + 1
end
call adrEdit 'save'
end
else do
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
do while ix < ax
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
ox = ox + 1
oo.ox = li
end
do while ix < m.ib.0
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
call writeDsn vGet('dsn'), 'OO.', ox, 1
end
end
else
call err 'implement save' m.tx.save
m.tx.save = 0
return
endProcedure txSave
/*--- return first non Space (Empty) char from str, '' if all spaces -*/
firstNE: procedure expose m.
parse arg str
c1 = verify(str, ' ')
if c1 > 0 then
return substr(str, c1, 1)
return ''
endProcedure firstNE
/*--- continue testcase
maximal cnt steps,
until testcase has to wait or is at end --------------------*/
txCont: procedure expose m.
parse arg cnt
cmp = m.tx.comp
call compBegin cmp
scn = m.cmp.scan
run = ''
one = ''
instr = ''
do forever
inst1 = ''
one = compile(cmp, ':')
if scanEnd(scn) then do
end
else if left(m.scn.src, m.scn.pos-1) <> '' then
call scanErr scn, 'bad text before tx instruction'
else if scanLit(scn, '+', '-') then do
if m.scn.tok == '+' then do
call scanName scanSkip(scn)
if translate(m.scn.tok) <> 'OK' then do
say m.scn.src
return
end
instr = ''
end
call scanNl scn, 1
end
else if scanName(scn) then do
fun = m.scn.tok
if wordPos(translate(fun), 'CREDB MANUAL NOP') < 1 then
call scanErr scn, fun 'is no tx instruction'
inst1 = word(scanPos(scn), 1) fun compExpr(cmp, 's', '=')
end
else
call scanErr scn, fun 'bad tx instruction'
if instr <> '' then do
do rx = 1 to words(run)
call oRun word(run, rx)
end
run = ''
call txIni
parse var instr m.tx.inPos fun rAst
cd = 'res = txFun'fun'('compAst2Rx(cmp, '-', rAst)')'
m.tx.outSta = 0
interpret cd
say 'res' res 'outSta' m.tx.outSta 'from' cd
if m.tx.outSta = 2 then
return
if m.tx.outsta \== 1 then
call err 'bad outSta' m.tx.outSta 'after' code
end
instr = inst1
run = run one
if instr = '' & scanEnd(scn) then
return
end
call err 'no paseran'
endProcedure txCont
txIni: procedure expose m.
if m.tx_ini then
return
call wshRun tx, ':', file(vGet('ini'))
m.tx_ini = 1
return
endProcedure txIni
/*--- output a status line -------------------------------------------*/
txOutSta: procedure expose m.
parse arg op fun, rest
if m.tx.save = 0 then
m.tx.save = 2
else if m.tx.save <> 2 then
call err 'txOutSta but save='m.tx.save
fun = strip(fun)
if op == '+' then do
m.tx.outSta = max(m.tx.outSta,
, 1 + (wordPos(translate(fun), 'RUN WAIT') > 0) )
end
else if op \== '-' then
call err 'bad op' op 'in txOutSta('op fun',' rest')'
call mAdd 'TX.OUTADD', m.tx.inPos op fun strip(rest)
say 'outSta' m.tx.outSta 'after' op fun strip(rest)
return
endProcedure txOutSta
/*--- do nothing and continue-----------------------------------------*/
txFunNop: procedure expose m.
parse arg opts
if vHasKey('nopCount') then
old = vGet('nopCount')
else
old = 0
call txOutSta '= nopCount', old+1
call txOutSta '+ ok', 'nop'
call txOutSta '- nop', 'opts =' opts
call txOutSta '- nop', 'opts =' opts
return 1
endProcedure txFunNop
/*--- Manual action required -----------------------------------------*/
txFunManual: procedure expose m.
parse arg opts
call txOutSta '+ wait', opts
say 'manual <'opts'>'
return 1
endProcedure txFunManual
/*--- creDb: sql creates, date etc. ----------------------------------*/
txFunCreDb: procedure expose m.
parse arg dst pha .
say 'txFunCreDb' dst pha 'ddl' vGet('ddl')
if wordPos(dst, 'src trg') < 1 then
call err 'creDb bad dest should be src or trg not' dst
if pha = '' | verify(pha, '0123456789') > 0 then
call err 'creDb not natural number but' pha
call vPut 'phase' , strip(pha)
call vPut 'env' , dst
call vPut 'dbSys' , vGet(dst'dbSys' )
call vPut 'db' , vGet(dst'db' )
call vPut 'creator', vGet(dst'creator')
call vPut 'cr', vGet(dst'creator')
gen = vGet('gen')
if gen \== '' then
gen = gen'('vGet('mpr')left(dst, 1)pha')'
call pipe '+F', file(gen '::f')
call wshRun tx, '=', file(vGet('ddl'))
call pipe '-'
/* call adrIsp "edit dataset('"gen"')", 4 */
call dbConn vGet('dbSys')
m.sq.ignore.drop = '-204'
j72 = 0
if vHasKey('j72') then
j72 = vGet('j72')
call sqlProc file(gen), j72
call txOutSta '+ ok', 'creDb' gen
return 1
endProcedure txCreDb
/* copy wsh ab hier ???????*/
/* rexx ***************************************************************
wsh: walter's rexx shell version 6.2
interfaces: 1.11.16
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
wsh s: sql processor
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
==> previous version under wsh4 <==
--- history -----------------------------------------------------------
27.10.16 walter: nur 1 system in rq2, jTalkRdr, mark sqlClosed
*********/ /*** end of help *******************************************
21.10.16 walter: set current packageSet / path ... ohne immediate
7.10.16 walter: fix redirection Hook mit only < >, fTst
30. 9.16 walter: blkSize fix fuer csmAlloc, csmAppc mit timeout
8. 9.16 walter: redirection hook
6. 9.16 walter: dsnCopy supports different recFM and lRecL
avoid csm errors: mbrList dsn on Sequential,
lrecl < 272 without blksize on rmtOut
12. 8.16 walter: f recursive %( %, %), fTst B,I,Y,Z / comp table deimp
if, else, proc etc. erlaub nl, * Kommentare für % und ^
29. 7.16 log for s_users to dsn.wshLog else to tss.ska.db2.wshlog
allow dd out sysout, assume reclen 32755 / spell out truncat.
13. 7.16 sqlFTabAdd und fTabAddRCT ersetzt druch ftabAdd
6.16 neues sql, sqlWsh, wshMain etc., test to end
23.12.15 dsnList, dsnCopy und dsnDel
16. 1.15 f: get/put read/write in/out Object/Strings transparent weiter
17.11.14 f: iirz2p ==> plex Buchstaben
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
**********************************************************************/
/*--- main code wsh -------------------------------------------------*/
call errReset 'hI'
numeric digits 12 /* full int precision, but not bigInt | */
m.myLib = 'A540769.WK.REXX'
m.myWsh = 'WSH'
m.myVers = 'v62e 1.11.16'
call wshLog
parse arg spec
isEdit = 0
editDsn = ''
m.wsh.outLen = 157
if spec = '' & m.err_ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
editDsn = dsnSetMbr(d, m)
if abbrev(editDsn, 'A540769.WK.REXX(WS') ,
& length(dsnGetMbr(editDsn)) <= 4 then do
isEdit = 0
if spec = '' then
spec = 't'
end
end
end
spec = strip(spec)
if spec = '?' then
return help()
inp = ''
out = ''
call utIni
if m.err_os == 'TSO' then do
if isEdit then do
call pipeIni
parse value wshEditBegin(wsh) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
call pipeIni
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if useOut = 0 then do
out = file('dd(out)')
m.wsh.outLen = sysLrecL - 4 * abbrev(sysRecFM, 'V')
end
else if (useOut = 16 & sysReason = 2) then do
end /* dd out not allocated, use say to sysTsPrt */
else if (useOut = 16 & sysReason = 3) then do
out = file('dd(out)') /* hope for sysout */
m.wsh.outLen = 32755 /* assume large maxRecL */
end
else if \ (useOut = 16 & sysReason = 2) then do
call err 'listDsi dd out cc='useOut ,
|| ', sysReason='sysReason 'm2='sysMsgLvl2 ,
|| ', m1='sysMsgLvl1
end
end
end
else if m.err_os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err_os
m.wsh.pipeCnt = (out \== '') * 2
if m.wsh.pipeCnt == 2 then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
if isEdit then
call wshEditEnd wsh
do m.wsh.pipeCnt
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'wsh end: pipe.0='m.pipe.0
else if m.err_cleanup <> '\?' | m.tso_ddAll <> '' then
call err 'wsh end: still err cleanups'
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if sysVar(sysNode) = 'RZ0' then
return
if abbrev(userid(), 'S') then
lNm = 'dsn.wshlog' /* da duerfen S-Pids */
else
lNm = 'tss.ska.db2.wshlog' /* da duerfen alle User */
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lN2 '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = m.myLib'('s3')' word(m.myVers, 1) sysvar(sysnode) ,
'j='mvsvar('symdef', 'jobname') ,
'u='userid() date('s') time()
if msg <> '' then
o.2 = left(msg, 80)
ox = 1 + (msg <> '')
if st <> '' then do sx=1 to m.st.0
ox = ox+1
o.ox = left(m.st.sx, 80)
end
call writedd log, o., ox
call tsoClose log
call tsoFree log
return
endProcedure wshLog
/*--- hook for out format -------------------------------------------*/
wshHook_outFmt: procedure expose m.
parse arg m, rest
if m.pipe.0 \== 4 then
call err 'wshHook_outFmt but pipe.0='m.pipe.0
call pipe '-'
if rest = 'e' then
call pipe '+F', csvV2Frdr(csvExtRdr(m.j.out), m.m.outLen-4)
else
call err 'wshHook_outFmt unsupported fmt='rest
return ''
endProcedure wshHook_outFmt
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg m, inp
mode = '*'
call wshIni
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call wshIni
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun wshHookComp( ,mode, jBuf(inp))
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- find input ramge, destination and set errHandler
and return input and output files ----------------------------*/
wshEditBegin: procedure expose m.
parse arg m
pc = adrEdit("process dest range Q", 0 4 8 12 16)
call adrEdit "(zLa) = lineNum .zl"
if pc = 16 then
call err 'bad range must be q'
rFi = 1
rLa = zLa
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
dst = ''
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
end
call jReset oMutate(m'.EDITIN', m.class_JBuf)
b = m'.EDITIN.BUF'
bx = 0
do lx=rFi to rLa
call adrEdit "(li) = line" lx
if abbrev(li, '$#end') then do lx=lx+1 to rLa ,
until abbrev(li, '$#out')
end
if abbrev(li, '$#out') then do
if dst = '' then
dst = lx - 1
leave
end
bx = bx + 1
m.b.bx = li
end
m.b.0 = bx
m.m.editRFirst = rFi
m.m.editREnd = rFi + bx
m.m.editDst = dst
if dst == '' then do
m.m.editOut = ''
end
else do
call adrEdit '(recl) = LRECL'
m.m.outLen = recL
m.m.editOut = jOpen(jReset(oMutate(m'.EDITOUTF',
, m.class_JBuf)), '>')
call jWrite m.m.editOut, left('$#out', 50) date('s') time()
end
call errReset 'hso', "return wshEditErrH('"m"', ggTxt)"
return m'.EDITIN' m.m.editOut
endProcedure wshEditBegin
/*--- copy output to editArea ---------------------------------------*/
wshEditEnd: procedure expose m.
parse arg m
call errReset 'h'
if m.m.editOut == '' then
return 0
call jClose m.m.editOut
call wshEditInsertSt wshEditInsertCmd(m.m.editDst, 'wshDs'),
, , m.m.editOut'.BUF'
call wshEditLocate m.m.editDst, 1
return 1
endProcedure wshEditEnd
/*--- scroll such that given line is nicely visible -----------------*/
wshEditLocate: procedure
parse arg ln, top
call adrEdit 'down max'
call adrEdit '(fi, la) = display_lines'
if top then
lx = ln - 7
else
lx = ln - la + fi + 7
if fi <> 1 & lx < fi then
call adrEdit 'locate' max(1, lx)
return
endProcedure wshEditLocate
/*--- error handle for wsh in edit mode
mark location of wsh syntax error -----------------------------*/
wshEditErrH: procedure expose m.
parse arg m, ggTxt
call errReset 'hso'
ee = errSay(ggTxt'\nin wsh phase' m.m.info)
isScan = 0
if wordPos("pos", m.ee.3) > 0 ,
& pos(" in line ", m.ee.3) > 0 then do
parse var m.ee.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ee.3 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
call wshEditEnd m
if m.m.Info=='compile' & isScan then do
lx = m.m.editRFirst + lin - 1
cmd = wshEditInsertCmd(lx, 'wshEr')
if pos \= '' then
call wshEditInsert cmd, 'msgline', right('*',pos)
call wshEditInsertSt cmd, 'msgline', ee
call wshEditLocate lx, 0
end
call errCleanup
exit 8
exit
endSubroutine wshEditErrH
/*--- return editor insert cmd for after line afX -------------------*/
wshEditInsertCmd: procedure
parse arg afX, lb
call adrEdit "(zLa) = lineNum .zl"
if afX >= 1 & afX < zLa then do
call adrEdit 'label' (afX+1) '= .'lb
return 'line_before .'lb '='
end
else if afX = zLa then
return 'line_after .zl ='
else
call err 'dst='afX 'but .zl='zLa
endProcedure wshEditInsertCmd
/*--- insert lines, format msgLines ---------------------------------*/
wshEditInsert: procedure
parse arg cmd, type
do ax=3 to arg()
li = strip(arg(ax), 't')
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return
endProcedure wshEditInsert
/*--- insert all lines of stem st -----------------------------------*/
wshEditInsertSt: procedure expose m.
parse arg cmd, type, st
if cmd == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
do ax=1 to m.st.0
call wshEditInsert cmd, type, m.st.ax
end
return
endProcedure wshEditInsertSt
/*** end wsh, begin all copies ***************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlIni
call fTabIni
call csmIni
return
endProcedure wshIni
/*--- call hooks and/or compile wsh
finally execute any generated code ----------------------------*/
wshRun: procedure expose m.
parse arg m, spec, inp
m.m.info = 'compile'
r = wshHookComp(m, spec, inp)
m.m.info = 'run'
if r \== '' then
call oRun r
return
endProcedure wshRun
/*--- call hooks, handle $# clauses, compile wsh
return generated code as ORunner or ''-------------------------*/
wshHookComp: procedure expose m.
parse arg m, spec, inp
if m == '' then do
if symbol('m.wsh_new') \== 'VAR' then
m.wsh_new = 1
else
m.wsh_new = m.wsh_new + 1
m = 'wsh_new'm.wsh_new
end
m.m.in = inp
m.m.comp = ''
m.m.kind = '@'
m.m.out = ''
m.m.wshEnd = 0
run = ''
rest = strip(spec)
if abbrev(rest, '$#') then
rest = strip(substr(rest, 3))
workDone = 0
do until m.m.comp \== '' | (workDone & rest = '')
if pos(left(rest, 1), '<>') > 0 then do
parse var rest s2 r2
end
else do
workDone = 1
parse var rest s2 '$#' r2
end
run = run wshHook(m, strip(s2), rest)
rest = strip(r2)
end
if m.m.comp \== '' then do
c = m.m.comp
s = m.c.scan
do while \ m.m.wshEnd
if \ scanLit(s, '$#') then
leave
call scanChar s
sp2 = m.s.tok
run = run wshHook(m, sp2, sp2)
end
call compEnd c, left(m.m.kind, \ m.m.wshEnd)
end
run = space(run, 1)
if words(run) <= 1 then
return run
else
return oRunner('call oRun' repAll(run, ' ', '; call oRun '))
endProcedure wshHookComp
/*--- compile wsh until eof or unknown syntax -----------------------*/
wshHook: procedure expose m.
parse arg m, spec, specAll
parse var spec sp1 spR
if pos(left(sp1, 1), '<>') > 0 then
return wshHookRedir(m, sp1 spR)
if verifId(sp1) > 0 | sp1 == '' then
return wshCompile(m, specAll)
if wordPos(sp1, 'out end version') <= 0 then do
cd = "return wshHook_"sp1"(m, '"strip(spR)"')"
/* say 'interpreting hook' cd */
interpret cd
end
c = m.m.comp
s = m.c.scan
if c == '' then
call err 'wshHook before compiler created:' spec
else if sp1 == 'out' then do
m.m.out = scanPos(s)
m.m.wshEnd = 1
end
else if sp1 == 'end' then
call scanNlUntil s, '$#out'
else if m.s.tok == 'version' then
call scanErr s, 'implement version'
return ''
endProcedure wshHook
/*--- initialize compiler if necessary and compile one unit ---------*/
wshCompile: procedure expose m.
parse arg m, spec
spec = strip(spec, 'l')
if m.m.comp == '' then
call wshIni
if pos(left(spec, 1), m.comp_chKind'*') > 0 then
parse var spec m.m.kind 2 spec
if m.m.comp == '' then do
c = comp(m.m.in)
m.m.comp = c
call compBegin c, spec
end
else do
c = m.m.comp
call scanBack m.c.scan, spec
end
return compile(c, m.m.kind)
endProcedure wshCompile
/*--- redirection hook ----------------------------------------------*/
wshHookRedir: procedure expose m.
parse upper arg m, op 2 dsn
call pipeIni
f = ''
if op == '<' then
call pipe '+f', , file(dsn)
else if op \== '>' then
call err 'bad op' op 'in wshHookRedir' op || dsn
else do
if pos('>', dsn) > 0 then
parse var dsn f '>' dsn
else if verify(dsn, '.~/', 'm') > 0 then
nop
else if abbrev(dsn, 'E') | abbrev(dsn, 'VV') ,
| abbrev(dsn, 'VF') then
parse var dsn f 2 dsn
else
f = 'E'
dsn = strip(dsn)
if dsn \== '' & verify(dsn, '.~/:', 'm') == 0 then
dsn = '::'dsn
if f <> '' then
call pipe '+F', fEdit(dsn, f)
else
call pipe '+F', file(dsn)
end
m.m.pipeCnt = m.m.pipeCnt + 1
return ''
endProcedure wshHookRedir
/* copy wshCopy end ************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy sort begin ***************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ***************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy comp begin ****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
**********************************************************************/
/***** initialisation ************************************************/
/*--- module initialisation -----------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = m.ut_space
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp_idChars = m.ut_alfNum'@_'
m.comp_wCatC = 'compile'
m.comp_wCatS = 'do withNew with for forWith ct proc arg if else'
m.comp_astOps = m.comp_chOp'])&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ---------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile one unit of the source with kind ki
and return oRunner with the code -------------------------*/
compile: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
a = ''
if m.m.end \== '' then
call scanNlUntil s, '$#out'
else if ki == '*' then
call scanNlUntil s, '$#'
else
a = compUnit(m, ki, '$#')
if compIsEmpty(m, a, 0) then
return ''
cd = compAst2Rx(m, ']', a)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m, erKi
s = m.m.scan
if erKi \== '' then
if \ scanEnd(s) then
return scanErr(s, 'wsh' compKindDesc(erKi),
"expected: compile stopped before end of input")
call scanClose s
return m
endProcedure compEnd
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '[')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '[')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '[-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code -----------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/[') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause -----------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code --------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAst(m, '[')
nlLe = 0 /* sophisticated logic using left and right NLs*/
do forever
one = compExprStm1(m, ki, nlLe)
if one == '' then
return compAstFree0(res)
call mAdd res, one
nlLe = scanNl(s)
end
endProcedure compExprStmts
/*--- scan over space comm nl until next
expression or statement and compile it --------------------*/
compExprStm1: procedure expose m.
parse arg m, ki, nlLe
s = m.m.scan
if pos(ki, ':%^') > 0 then do /* statements with $ are ok */
call compSpNlComment m, '*'
if ki \== ':' then do
one = compExpr(m, 's', ki)
if one \== '' then
return one
end
end
else if ki == '@' then do /* rexx statements */
call compSpNlComment m
one = compExpr(m, 's', ki)
if one\ == '' then do
if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
do forever /* scan all continued rexx lines */
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
return compAstFree0(one)
end
end
else do /* statemens need $, nl logic for expr */
do forever /* tricky logic for empty lines */
do forever
sx = m.s.pos
call scanSpaceOnly s
if \ compComment(m) then
leave
nlLe = 0
end
m.s.pos = sx
one = compExpr(m, 'd', ki)
nlRi = scanNL(s, '?')
if one == '' then do
if nlLe & nlRi then
return compAst(m, translate(ki, ';-', '@=') ,
, ,compAst(m,'='))
end
else if m.one.containsD then
return one
if \ nlRi then
leave
nlLe = scanNL(s)
end
end
return compStmt(m, ki)
endProcedure compExprStm1
/*--- compile a single statement ------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compExprStm1(m, ki, 0),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compExprStm1(m, ki, 0),
, 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compExprStm1(m, ki, 0),
, "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'withNew' then do
oldVars = m.m.comp_assVars
m.m.comp_assVars = ''
one = compCheckNN(m, compExprStm1(m, ki, 0), 'after withNew')
r = compAst(m, 'F', 'withNew', '', one,
, compAst(m, '*', '].'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
m.m.comp_assVars = oldVars
return r
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compExprStm1(m, ki, 0), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
if fu == 'if' | fu == 'else' then do /* unchanged rexx */
call scanBack s, fu
return compExpr(m, 's', '@')
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '[' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '[' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '[' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit -----------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '[', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '[' then
stopper = m.comp_chDol']'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/**** lexicals *******************************************************/
/*--- skip a comment. return 0 if there is none ---------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments --------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ---------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp_wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp_wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '[' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ***************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
[ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ] execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
**********************************************************************/
/*--- create a new AST ----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '[;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ---------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST -------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg -------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')]') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ']') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == ']' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '[' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '[' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, ']', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@])') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,']', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, ']', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, ']', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, ']', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, ']', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'wshHookComp( ,'args ',in2Buf())')
end
return compAstErr(a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a)
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '[' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects ---------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp_idChars) > 0 then
if pos(rl, m.comp_idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procedure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end *************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
**********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left -----------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start ----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position -------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end ************************************************/
/* copy scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ---------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier --------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier -------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end ************************************************/
/* copy scanUtil begin ************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values --------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets -------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut ----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl=='n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end *************************************************/
/* copy pipe begin ****************************************************
**********************************************************************/
pipeIni: procedure expose m.
if m.pipe_ini == 1 then
return
m.pipe_ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
m.j.out = m.pipe.ax.out
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
say '||| please use vIn instead fo vIn'
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end *****************************************************/
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader -----------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading ------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
if oKindOfString(m) then
return oNew('FileList', dsn2Jcl(oAsString(m)), opt)
else
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a ----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg || copies('.*', pos('*', arg) < 1)" ,
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy mat begin ****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end ****************************************************/
/* copy db2Util begin ************************************************/
/--- return (first) list of columns from punch file
i.e. lines between first pair of ( and ) on a line
used by abub gbGr ----------------------------------------------*/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure loadCols
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' m.in
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call out ' SORTDEVT DISK '
do in()
li = m.in
if pos('CHAR(', li) > 0 then
call out strip(li, 't') 'TRUNCATE'
else if word(li, 1) word(li, 3) == 'PART INDDN' then do
call out li,
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
call out ' DISCARDDN TDISC '
end
else
call out li
end
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy sqlDiv begin *************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa ------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), maxCh, maxBlo, maxDe)
/*--- default formats per datatype ----------------------------------*/
sqlFTabOpts: procedure expose m.
parse arg ff, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff --------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
/*--- complete / override column info from sqlCa --------------------*/
sqlFTabComplete: procedure expose m.
parse arg m, cx, aOth, aFmt
if aOth then
call sqlFTabOthers m, cx
f2x = classMet(sqlFetchClass(cx), 'f2x')
do tx=1 to m.m.0
c1 = m.m.tx.col
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
parse var m.m.set.sx c1 aDone
m.m.tx.done = aDone \== 0
m.m.tx.fmt = m.m.set.sx.fmt
m.m.tx.labelSh = m.m.set.sx.labelSh
end
if symbol('m.f2x.c1') \== 'VAR' then
iterate
kx = m.f2x.c1
if m.m.tx.labelLo = '' then
m.m.tx.labelLo = m.sql.cx.d.kx.sqlName
if m.m.tx.labelSh = '' then
m.m.tx.labelSh = m.sql.cx.d.kx.sqlName
if m.m.tx.fmt <> '' | \ aFmt then
iterate
/* use format for datatype */
ty = m.sql.cx.d.kx.sqlType
ty = ty - ty // 2 /* odd = with null */
le = m.sql.cx.d.kx.sqlLen
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
pr = m.sql.cx.d.kx.sqlLen.sqlPrecision
sc = m.sql.cx.d.kx.sqlLen.sqlScale
if sc < 1 then
f1 = '%' || (pr + 1) || 'i'
else
f1 = '%' || (pr + 2) || '.'sc'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
m.m.tx.fmt = f1
end
return m
endProcedure sqlFTabComplete
/*--- add all cols of sqlCA to fTab,
that are not yet (witho aDone=0) ----------------------*/
sqlFTabOthers: procedure expose m.
parse arg m, cx
do cy=1 to m.m.0
if m.m.cy.done then do
nm = m.m.cy.col
done.nm = 1
end
end
ff = m.sql.cx.fetchFlds
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
if done.c1 \== 1 then
call ftabAdd m, c1
end
return m
endProcedure sqlFTabOthers
/*--- fetch all rows from cursor cx, tabulate and close crs
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 0 then
return fTab(m, sqlQuery2Rdr(cx))
/* fTab would also work in other cases,
however, we do it without sqlQuery2Rdr */
dst = 'SQL_fTab_dst'
if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
do rx=1 while sqlFetch(cx, dst)
call out left('--- row' rx '', 80, '-')
call fTabCol m, dst
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
end
else do
call fTabBegin m
do rx=1 while sqlFetch(cx, dst)
call out f(m.m.fmt, dst)
end
call fTabEnd m
end
call sqlClose cx
return m
endProcedure sqlFTab
/*--- create insert statment into table tb
for object m in spufi (72chars) format ---------------------*/
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFldD(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState --------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/*say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ---------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ---------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end *************************************************/
/* copy db2Cat begin *************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'",,,, 'r')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq sq, colName col, ordering ord" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end *************************************************/
/* copy sqlWsh begin **************************************************
remote SQL using csmExWsh ************************************/
sqlConClass_w: procedure expose m.
if m.sqlWsh_ini == 1 then
return m.class_SqlWshConn
m.sqlWsh_ini = 1
call sqlConClass_S
call csmIni
call classNew 'n SqlWshRdr u CsmExWsh', 'm',
, "jReset call jReset0 m; m.m.rdr = jBuf()" ,
"; m.m.rzDb=arg; m.m.sql = arg2;m.m.type= arg(3)" ,
, "jOpen call sqlWshRdrOpen m, opt"
return classNew('n SqlWshConn u', 'm',
, "sqlRdr return oNew(m.class_sqlWshRdr, m.sql_conRzDb" ,
", src, type)" ,
, "sqlsOut return sqlWshOut(rdr,m.sql_conRzDB,retOk,m.ft.opt)")
endProcedure sqlConClass_w
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshRdrOpen: procedure expose m.
parse arg m, oOpt
r = m.m.rdr
m.r.buf.0 = 1
m.r.buf.1 = m.m.sql
parse var m.m.RzDb m.m.rz '/' dbSys
m.m.wOpt = 'e sqlRdr' dbSys
call csmExWshOpen m, oOpt
d = m.m.deleg
em = ''
do while jRead(d)
if objClass(m.d) \== m.class_S then do
m.d.readIx = m.d.readIx - 1
leave
end
em = em'\n'm.d
end
if em == '' then
return m
call jClose m.m.deleg
return err('sqlWshRdr got' substr(em, 3))
endProcedure sqlWshRdrOpen
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshOut: procedure expose m.
parse arg rdr, rzDb, retOk, oo
parse value dsnCsmSys(rzDb) with rz '/' dbSys
if pos('o', oo) > 0 then
spec = 'e sqlsOut'
else
spec = 'v' || (m.wsh.outLen+4) 'sqlsOut'
call csmExWsh rz, rdr, spec dbSys oo retOk
return 1
endProcedure sqlWshOut
/* copy sqlWsh end *************************************************/
/* copy sqlS begin **************************************************
sqlStmts **********************************************/
sqlConClass_S: procedure expose m.
if m.sqlS_ini == 1 then
return m.class_SqlConnS
m.sqlS_ini = 1
call sqlConClass_R
call scanWinIni
return classNew('n SqlConnS u SqlConn', 'm',
, "sqlsOut return sqlsOutSql(rdr, retOk, ft)")
endProcedure sqlConClass_S
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt, fOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk, fOpt)
endProcedure sqlStmts
/*--- output sql as table -------------------------------------------*/
sql2tab: procedure expose m.
parse arg src, retOk, ft
cx = m.sql_defCurs
if ft == '' then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c' , '-'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c','-'ft))
call sqlQuery cx, in2str(src, ' '), retOk
call sqlFTab ft, cx
return
endProcedure sql2tab
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, ft
if ft = '' then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , 'a'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , ft))
interpret classMet(m.sql_ConCla, 'sqlsOut')
sqlsOutSql: procedure expose m.
parse arg rdr, retOk, ft
m.sql_errRet = 0
cx = m.sql_defCurs
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' | m.sql.cx.fun == 'CALL' then
if m.ft.verbose then
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
if m.sql.cx.resultSet == '' then
iterate
do until \ sqlNextResultSet(cx) | m.sql_errRet
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
call out sqlMsgLine(m.sql.cx.fetchCount ,
'rows fetched', , m.r)
end
end
call jClose r
if m.sql_errRet then do
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
return \ m.sql_errRet
endProcedure sqlsOutSql
/*--- sql hook ------------------------------------------------------
hook paramter db | windowSpec | db? , windowSpec? , fTabOpt?
db: dbSys, rz/dbSysAbkürzung, 1 oder 2 chars
windowSpec: 0 = variable len, 123 = window123
default spufi = window72 ---------------------*/
wshHook_S: procedure expose m.
parse arg m, spec
parse var spec ki 2 rest
call errSetSayOut 'so'
if ki == '/' then do
inp = m.m.in
end
else do
call compIni
if pos(ki, m.comp_chKind) <= 0 then do
ki = '='
rest = spec
end
inp = wshCompile(m, ki)
end
if pos('@',rest)>0 then call err 'was ist das??????' spec
if words(rest)==1 & (datatype(rest, 'n') | pos('@',rest)>0) then
rest = ','rest
parse var rest dbSy ',' wOpt ',' fOpt
d2 = ii2rzDb(dbSy, 1)
call sqlConnect d2
m.m.info = 'runSQL'
if \ sqlStmts(inp, 'rb ret', strip(wOpt), , strip(fOpt)) then do
m.m.end = 1
m.m.exitCC = 8
end
call sqlDisConnect
return ''
endProcedure wshHook_s
/*--- wshHook for sqlRdr read from dd wsh --------------------------*/
wshHook_sqlRdr: procedure expose m.
parse arg m, dbSys
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if \ m.sql_errRet then
r = sqlRdr(m.m.in)
if \ m.sql_errRet then
call jOpen r, '<'
if \ m.sql_errRet then do
call pipeWriteAll r
call jClose r
end
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
/* else
call out sqlMsgLine(m.r.bufI0 'rows fetched', , m.r.srcTxt) */
call sqlDisConnect
return ''
endProcedure wshHook_sqlRdr
/*--- wshHook for sqlsOut read from dd wsh --------------------------*/
wshHook_sqlsOut: procedure expose m.
parse arg m, dbSys oo retOk
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if oo == 'a' | oo == 't' then do
myOut = m.j.out
m.myOut.truncOk = 1
end
if \ m.sql_errRet then
call sqlsOut m.m.in, retOk, oo
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
call sqlDisConnect
return ''
endProcedure wshHook_sqlsOut
/* copy sqlS end *************************************************/
/* copy sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
call csmIni
call classNew 'n SqlCsmRdr u JRW', 'm',
, "jReset m.m.rzDb=arg; m.m.src=arg2; m.m.type=arg(4)" ,
, "jOpen call sqlCsmRdrOpen m, opt",
, "jClose" ,
, "jRead return 0"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlCsmExe:
parse arg ggRzDb, sql_query, ggRetOk
parse value dsnCsmSys(ggRzDb) with sql_host '/' sql_db2SSID
sql_query = strip(sql_query) /* csmASqls fails on leading spaces */
call csmAppc 'csmASql', , , 4
if sqlCode = 0 then
return 0
ggSqlStmt = sql_query /* for sqlMsg etc. */
if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset ------------------*/
sqlCsmRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
res = sqlCsmExe(m.m.rzDb, src, 100 retOk)
if res < 0 then
return res
if words(m.m.type) = 1 & \ abbrev(m.m.type, ' ') then
cl = class4name(m.m.type)
else if m.m.type <> '' then
cl = classNew('n* SqlCsm u f%v' m.m.type)
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsApp(vv, SQLDA_REXXNAME.kx)
end
cl = classNew('n* SqlCsm u f%v' vv)
end
ff = classFldD(cl)
if sqlD <> m.ff.0 then
return err('sqlCsmQuery sqlD' sqlD '<>' m.ff.0 'for' ,
className(cl))
do rx=1 to sqlRow#
m.m.buf.rx = m'.BUFD.'rx
call oMutate m'.BUFD.'rx, cl
end
m.m.buf.0 = sqlRow#
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
do rx=1 to sqlRow#
dst = m'.BUFD.'rx || m.ff.kx
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst = m.sqlNull
else
m.dst = value(rxNa'.'rx)
end
end
return 0
endProcedure sqlCsmRdrOpen
/* copy sqlCsm end *************************************************/
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlConClass_R: procedure expose m.
if m.sqlO_ini == 1 then
return m.class_sqlConn
m.sqlO_ini = 1
call sqlIni
call jIni
/* call scanReadIni */
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.sql = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
return classNew('n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return err('no stmts/sqlsOut in conClass_R')")
endProcedure sqlConClass_R
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg srcRdr, type
src = in2str(srcRdr, ' ')
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = m.m.sql
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys
cCla = connectionClass
e = rexx local only
r = rexx local only, rdr&objects
s = rexx local only, rdr&objects, stmts (default local)
c = with csmASql , rdr&objects
w = with sqlWsh , rdr&objects, stmts (default remote) ----*/
sqlConnect: procedure expose m.
parse arg sys, cCla
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if pos('/', sys) <= 0 then
cCla = firstNS(translate(cCla, 'rs', 'cw'), 's')
else if cCla = '' then
cCla = 'w'
if cCla == 'e' then
m.sql_conCla = 'sql E no connection class'
else
interpret 'm.sql_conCla = sqlConClass_'cCla'(sys, cCla)'
if pos(cCla, 'ers') == 0 then do
m.sql_conRzDB = sys
return
end
call sqlIni /* initialize dsnRexx */
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
m.sql.cx.sqlClosed = 1
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
return csmEx2('csmExec' arg(1), arg(2))
/*--- execute a single csmAppc start command
arg(1)=pgm, arg(2)=parm, arg(3)=rest, arg(4)=retOk ------------*/
csmAppc:
appc_rc = 0 /* csmAppc erstellt diese Variable nicht immmer| */
appc_msg.0 = 0
if 0 <> csmEx2('csmAppc start pgm('arg(1)')' ,
copies("parm("quote(arg(2), "'")")",
, arg(2) <> '') arg(3) , arg(4)) then
ggRc = m.tso_rc
else if appc_rc = 0 then
return 0
else do
ggRc = appc_rc
m.csm_err = ''
m.csm_errMsg = 'tso_rc=0'
end
ggMsg = 'csmAppc rc='ggRc 'appc_rc='appc_rc ,
'reason='appc_reason 'state_c='appc_state_c appc_state_f ,
'\n SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ggCsmIx=1 to appc_msg.0
ggMsg = ggMsg '\n ' appc_msg.ggCsmIx
end
m.csm_errMsg = ggMsg'\n'm.csm_errMsg
return ggRc
endRoutine csmAppc
/*--- execute single command in arg(1) -----------------------------*/
csmEx2:
if wordPos(translate(word(arg(1), 2)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if pos('TIMEOUT(' , translate(arg(1))) > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso(arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else if pos('CSMAP47E TP timed out', m.tso_trap) > 0 then
m.csm_err = 'timeout'
else
m.csm_err = ''
m.csm_errMsg = strip('csm' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='m.tso_stmt m.tso_trap ,
'\ntime='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endRoutine csmEx2
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
dd = tsoDD(csmDel, 'a')
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname("dd")", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname("dd")", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName("dd") member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then
return tsoFree(dd)
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call tsoFree dd
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call tsoFree dd
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
say 'please use dsnCopy instead of depreceated csmCopy'
return dsnCopy(fr, to, mbrs)
csmCop2: procedure expose m.
parse upper arg o1 o2, fr, to tA1 ':' tA2, mbrs
frDD = tsoDD('csmFrDD', 'a')
tAt = strip(tA1 firstNS(tA2, ':D'frDD))
toDD = tsoDD('csmToDD', 'a')
mbr1 = abbrev(o2, '&') & words(mbrs) = 1
if mbr1 then do
parse value strip(mbrs) with fMb '>' tMb
call csmAlloc fr'('fMb')', frDD, 'shr'
tM2 = firstNS(tMb, copies(fMb, o2 <> '&-'))
call csmAlloc dsnSetMbr(to, tM2), toDD, 'shr', , tAt
end
else do
call csmAlloc fr, frDD, 'shr'
call csmAlloc to, toDD, 'shr', , tAt
end
if m.tso_recFM.frDD <> m.tso_recFM.toDD ,
| m.tso_lRecL.frDD <> m.tso_lRecL.toDD then do
call tsoFree frDD toDD
return if(m.tso_lRecL.frDD <= m.tso_lRecL.toDD, 'W', 'T')
end
inDD = tsoDD('csmInDD', 'a')
i.0 = 0
if abbrev(o2, '&') & \ mbr1 then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = tsoDD('csmOuDD', 'a')
call dsnAlloc('dd('outDD') new ::V137')
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
isNew = wordPos(disp, 'NEW MOD CAT') > 0
if isNew & nn \== '' then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
recFm = substr(rest, cx+6, 1)
cy = pos(')', rest, cx)
if cy > cx then
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6),
, 0) || substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then
rest = insert('inder', rest, cx+2)
if isNew then
if pos(' BLKSIZE(', ' 'translate(rest)) <= 0 then do
/* without blkSize csm will fail to read for rec < 272 */
cx = pos(' LRECL(', ' 'translate(rest))
lrecl = substr(rest, cx+6,
, max(0, pos(')', rest, cx+6) - cx - 6))
blk = 32760
if datatype(lRecl ,'n') & translate(recfm) = 'F' then
blk = blk - blk // lRecL
rest = rest 'blkSize('blk')'
end
noRetry = retRc <> '' | isNew | nn == ''
alRc = adrCsm('allocate' a1 rest, if(noRetry, retRc, '*'))
m.tso_dsorg.dd = subsys_dsOrg
m.tso_recFM.dd = subsys_recFM
m.tso_blkSize.dd = subsys_blkSize
m.tso_lRecL.dd = subsys_lRecL
if alRc = 0 then
return 0
m.tso_dsnNF.dd = pos('CSMSV29E DATA SET' dsnSetMbr(dsn) ,
'NOT IN CATALOG', m.tso_trap) > 0
if noRetry | \ m.tso_dsnNF.dd then
if pos('*', retRc) > 0 | wordPos(alRc, retRc) > 0 then
return alRc
else
return err(m.csm_errMsg)
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('fUnit2I('b', tracksused.1) ,
|| ',' fUnit2I('b', tracks.1)') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
csmMbrList: procedure expose m.
parse arg m, sys, dsn, msk
/* attention mbrList dataset(....)
does not cleanup proberly if dsn is NOT PO
and much later on follow errors appear
which are hard to debug| */
if dataType(dsnAlloc(sys'/'dsn, , mbrLisDD, 8), 'n') then do
say sys dsn
say m.tso_trap
m.m.dsnNF = m.tso_dsnNF.mbrLisDD
if \ m.m.dsnNF then
call err m.csm_errMsg
m.m.0 = -99
end
else do
m.m.dsnNF = 0
m.m.RECFM = m.tso_RECFM.mbrLisDD
m.m.LRECL = m.tso_LRECL.mbrLisDD
m.m.BLKSIZE = m.tso_BLKSIZE.mbrLisDD
m.m.DSORG = m.tso_DSORG.mbrLisDD
if m.m.DSORG \== 'PO' then
m.m.0 = -98
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
call adrCsm "mbrList ddName(mbrLisDD)" msk ,
"index(' ') short"
m.m.0 = mbr_name.0
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
end
call tsoFree mbrLisDD
end
return m.m.0
endProcedure csmMbrList
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
cmd the tso command to execute
---------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) -------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, cmd, keepTsPrt, retOk
do cx=1 to (length(cmd)-1) % 68 /* split tso cmd in linews */
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmTsPrt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
m.csm_exRxMsg = ''
m.csm_exRxRc = csmappc("csmexec" ,
, "select tsocmd('csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc')", , "*")
if m.csm_exRxRc <> 0 then do /* handle csm error */
call readDD 'rmTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmTsPrt
msg = '\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
do lx=1 to min(100, m.csm_tsPrt.0)
msg = msg'\n'strip(m.csm_tsPrt.lx, 't')
end
l2 = max(lx, m.csm_tsPrt.0-99)
if l2 > lx then
msg = msg'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines' l2 'to' m.csm_tsPrt.0, 79, '-')
do lx=l2 to m.csm_tsPrt.0
msg = msg'\n'strip(m, m.csm_tsPrt.lx, 't')
end
m.csm_exRxMsg = 'cmsExRx rc='ggRc m.csm_errMsg || msg ,
'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call sayNl m.csm_exRxMsg */
end
call tsoFree rmSyPro rmtSys rmtsIn copies(rmTsPrt, keepTsPrt\==1)
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call sayNl m.csm_exRxMsg
else
call err m.csm_exRxMsg
end
return m.csm_exRxRc
endProcedure csmExRx
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmtWsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = firstNS(oOpt, 'v')
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
if o2 == 'p' then do
fo = file('dd(rmTsPrt)')
end
else do
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
end
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec,
, o2 == 'p' , '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH' wSpec,
, o2 == 'p' , '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc,0 4)<1 then call err m.csm_ExRxMsg;",
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/* copy csm end ******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP' /* 'RQ2/DVBP' */ ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP' /* 'Q25/DVBP' */ ,
'Z25/DEVG Y25/DEVG X25/DEVG'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
call iiIni
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy csv begin ****************************************************/
/**** csvRdr reads a text file, in csv format
and creates a class from column head in first line
csvRdr#jRead returns the create objects ************************/
csv2ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv2ObjRdr', 'm.m.opt = arg2' ,
, 'call csv2ObjBegin m' ,
, 'call csv2Obj m, rStem, $i'), rdr, opt)
csv2ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return m
endProcedure csvRdrOpenFinish
csv2Obj: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(translate(li, ' ', ','), 1))
call mAdd wStem, csv2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csv2Obj
/*--- convert csv line into object of class cl ----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
/*--- clear remaining fields and stems and mutate -------------------*/
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/**** csvWordRdr: similar to csvRdr, but input line format
are quoted or unquoted words ****************************/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvWordRdr', 'm.m.opt = arg2' ,
, 'call csvWordBegin m' ,
, 'call csvWord m, rStem, $i'), rdr, opt)
csvWordBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvWord: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(li, 1))
call mAdd wStem, csvWord2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csvWord
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWord2O
/**** csvColRdr: similar to csvRdr, but input format
are fixed width columns *********************************/
/*--- create object for fixLenColumns format ------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvColRdr', 'm.m.opt = arg2' ,
, 'call csvColBegin m' ,
, 'call csvCol m, rStem, $i'), rdr, opt)
csvColBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvCol: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then do
s = scanSrc(csv_colOpen, li)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
end
call mAdd wStem, csvCol2O(m, mNew(m.m.class), m.m.class, li)
return
endProcedure csvCol
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- csv4obj add a header line
and objects of the same class in csv format ---------------*/
csv4ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv4ObjRdr', ,
, 'call csv4ObjBegin m' ,
, 'call csv4Obj m, rStem, $i'), rdr, opt)
csv4ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
endProcedure csv4ObjBegin
csv4Obj: procedure expose m.
parse arg m, wStem, o
if o == '' then do
if m.m.class \== '' then
call mAdd wStem, ''
return
end
cl = objClass(o)
if cl \== m.m.class then do
if m.m.class \== '' then
return err('class('o')='cl '<>' m.m.class)
m.m.class = cl
ff = classMet(cl, 'oFlds')
if m.ff.0 < 1 then
return err('no fields in' cl)
t = ''
do fx=1 to m.ff.0
t = t','m.ff.fx
end
call mAdd wStem, substr(t, 2)
m.m.oFldD = classMet(cl, 'oFldD')
end
call mAdd wStem, csv4O(o, m.m.oFldD, 0)
return
endProcedure csv4Obj
/*--- return the csv string for an object ---------------------------*/
csv4o: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 == oNull then
res = res','
else if pos(',', v1) > 0 | pos('"', v1) > 0 | v1 == '' then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4o
/*--- fill empty fieldds with value of previous row -----------------*/
csvE2PrevRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvE2PrevRdr', 'm.m.opt = arg2' ,
, "m.m.prev = ''" ,
, 'call csvE2Prev m, rStem, $i'), rdr, opt)
/*--- externalize o and add to wStem --------------------------------*/
csvE2Prev: procedure expose m.
parse arg m, wStem, o
if o == '' then
return
ff = oFldD(o)
hasData = 0
do fx=1 to m.ff.0
f1 = o || m.ff.fx
if m.f1 \== '' then do
hasData = 1
iterate
end
if m.m.prev == '' then
iterate
p1 = m.m.prev || m.ff.fx
m.f1 = m.p1
end
if \ hasData then
return
call mAdd wStem, o
m.m.prev = o
return
endProcedure csvE2Prev
csvColBegin: procedure expose m.
/**** csvExt externalises object into csvExt format
including object cycles and classes
csv+ protocoll, first field contains meta info ---------------------
v,text null or string
w,text w-string
c name classAdr,flds class definition
b name classAdr, class forward declaration
m name adr,text method
o classAdr adr,flds object definition and output
d classAdr adr,flds object definition wihtout output
f classAdr adr, object forward declaration
r adr, reference = output of already defined objects
* text unchanged text including ' " ...
* flds csv flds
**********************************************************************/
csvExtRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvExtRdr', ,
, 'call csvExtBegin m',
, 'call csvExt m, rStem, $i'), rdr, opt)
csvExtBegin: procedure expose m.
parse arg m
d = m'.DONE'
call mapReset d, 'K'
call mapPut d, m.class_class, 'class'
call mapPut d, m.class_v, 'v'
call mapPut d, m.class_w, 'w'
call mapPut d, m.class_o, 'o'
return m
endProcedure csvExtBegin
/*--- externalize o and add to wStem --------------------------------*/
csvExt: procedure expose m.
parse arg m, wStem, o
c = objClass(o)
if c == m.class_W then
return mAdd(wStem, 'w,'substr(o, 2))
if oKindOfString(o) then
return mAdd(wStem, 'v,'o)
if c == m.class_class then
call csvExtClass m, wStem, o
if m.m.done.o == 0 then do
m.m.done.o = 1
call mAdd wStem, 'f' csvExtClass(m, wStem, c) o','
end
if symbol('m.m.done.o') == 'VAR' then
return mAdd(wStem, 'r' o',')
return mAdd(wStem, 'o' c o || csvExtObjTx(m, wStem, o))
endProcedure csvExt
csvExtObjTx: procedure expose m.
parse arg m, wStem, o
call mapAdd m'.DONE', o, 0
c = objClass(o)
if c \== m.class_class & pos(m.m.done.c, 12) < 1 then
call csvExtClass m, wStem, c
ff = classMet(c, 'oFldD')
r = ''
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then do
v1 = s2o(v1)
end
else if \ (c2 == m.class_N | c2 == m.class_W) then do
if m.m.done.v1 == 0 then do
m.m.done.v1 = 1
call mAdd wStem, 'f' c2 v1','
end
if symbol('m.m.done.v1') \== 'VAR' then
call mAdd wStem, 'd' c2 v1 ,
|| csvExtObjTx(m, wStem, v1)
end
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
m.m.done.o = 2
return r
endProcedure csvExtObjTx
csvExtClass: procedure expose m.
parse arg m, wStem, c
res = mapGet(m'.DONE', c, '-')
if res == 0 then do
m.m.done.c = 1
call mAdd wStem, 'b' if(m.c.name == '', '-', m.c.name) c','
return c
end
if res == 1 then
return c
if res \== '-' then
return res
call mapAdd m'.DONE', c, 0
ty = m.c
res = if(m.c.name == '', '-', m.c.name) c
if ty == 'u' then do
res = 'c' res',u'
if m.c.0 > 0 then do
r = ''
do cx=1 to m.c.0
r = r','csvExtClassEx(m, wStem, m.c.cx)
end
res = res substr(r, 2)
end
end
else if ty == 'm' & m.c.0 == 0 then
res = 'm' res','m.c.met
else
res = 'c' res','csvExtClassEx(m, wStem, c)
call mAdd wStem, res
call mapPut m'.DONE', c, c
return c
endProcedure csvExtClass
csvExtClassEx: procedure expose m.
parse arg m, wStem, c
res = ''
ch = c
do forever
g = mapGet(m'.DONE', c, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res csvExtClass(m, wStem, ch))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('csvExtClassEx bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure csvExtClassEx
/*--- convert variable len recs to fixLen
& = continuation, | end (to protect ' &|') -------------------*/
csvV2FRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvV2FRdr', 'm.m.maxLen = arg2',
, 'call csvV2FBegin m, m.m.maxLen',
, 'call csvV2F m, rStem, $i'), rdr, arg)
csvV2FBegin: procedure expose m.
parse arg m, maxL
m.m.maxLen = word(maxL 55e55, 1)
return m
endProcedure csvV2FBegin
csvV2F: procedure expose m.
parse arg m, wStem, line
if line \== '' & pos(right(line, 1), ' &|') > 0 then
line = line'|'
if length(line) <= m.m.maxLen then
return mAdd(wStem, line)
do cx=1 by m.m.maxLen-1 to length(line)-m.m.maxLen
call mAdd wStem, substr(line, cx, m.m.maxLen-1)'&'
end
return mAdd(wStem, substr(line, cx))
endProcedure csvV2F
/*--- f2v fixLen to variable len lines: &=continuation |=endMark ----*/
csvF2VRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvF2VRdr', ,
, 'call csvF2VBegin m' ,
, 'call csvF2V m, rStem, $i' ,
, 'call csvF2VEnd m'), rdr, arg)
csvF2VBegin: procedure expose m.
parse arg m
m.m.strt = ''
return m
endProcedure csvF2VBegin
csvF2V: procedure expose m.
parse arg m, wStem, aLi
li = strip(aLi, 't')
if right(li, 1) == '&' then do
m.m.strt = m.m.strt || left(li, length(li) - 1)
return
end
if right(li, 1) == '|' then
call mAdd wStem, m.m.strt || left(li, length(li) - 1)
else
call mAdd wStem, m.m.strt || li
m.m.strt = ''
return
endProcedure csvF2V
csvF2VEnd: procedure expose m.
parse arg m
if m.m.strt \== '' then
return err("csvF2vEnd but strt='"m.m.strt"'")
return m
endProcedure csvF2VEnd
/*--- internalize objects in ext format -----------------------------*/
csvIntRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvIntRdr', ,
, 'call csvIntBegin m',
, 'call csvInt m, rStem, $i'), rdr, opt)
csvIntBegin: procedure expose m.
parse arg m
m.m.forward = ''
d = m'.DONE'
call mapReset d, 'K'
return
endProcedure csvIntBegin
csvInt: procedure expose m.
parse arg m, wStem, line
parse var line hd ',' rest
parse var hd h1 h2 h3 hr
d = m'.DONE'
if pos(h1, 'vwr') > 0 then do
if m.m.forward \== '' then
return err('csvInt: forward='m.m.forward 'not empty:' line)
if h1 == 'v' & h2 == '' then
return mAdd(wStem, rest)
if h1 == 'w' & h2 == '' then
return mAdd(wStem, m.o_escW || rest)
if h1 \== 'r' | h2 == '' | h3 \== '' | rest \== '' then
return err('csvInt: bad line' line)
r = mapGet(d, h2, '')
if r == '' then
return err('csvInt: undefined reference' line)
return mAdd(wStem, r)
end
if h3=='' | hr\=='' | length(h1)\==1 | pos(h1, 'bcmdfo') < 1 then
return err('csvInt: bad line' line)
if h1 == 'b' | h1 == 'f' then do
if symbol('m.d.h3') == 'VAR' then
return err('csvInt: forward already defined:' line)
if h1 == 'b' then do
if h2 == '-' then
h2 = 'CsvForward'
n = classNew('n' h2 || (m.class.0+1) 'u')
m.n.met = h2'*'
end
else do
cl = mapGet(d, h2, '')
if cl == '' then
return err('csvInt: undefined class:' line)
n = mNew(cl)
end
call mapAdd d, h3, n
m.m.forward = m.m.forward h3
return
end
if h1 == 'm' then do
n = classNew('m' h2 rest)
return mapAdd(d, h3, n)
end
if h1 == 'c' then do
rx = 1
rr = ''
do while rx <= length(rest)
ry = pos(',', rest, rx+1)
if ry < 1 then
ry = length(rest)+1
r1 = substr(rest, rx, ry-rx)
rI = wordIndex(r1, words(r1))
if rI == 1 & abbrev(r1, ',') then
rI = 2
rL = strip(substr(r1, rI))
if length(rL) \== 1 | pos(rL, 'vwor') < 1 then do
rL = mapGet(d, rL, '')
if rL == '' then
return err('csvInt undef class' rL 'line:' line)
end
rr = rr || left(r1, rI-1)rL
rx = ry
end
end
fx = wordPos(h3, m.m.forward)
if fx > 0 then do
m.m.forward = strip(delWord(m.m.forward, fx, 1))
n = mapGet(d, h3)
if h1 == 'c' then do
call classNew 'n=' m.n.name rr
call classMet n, 'new'
return
end
cl = 'CLASS'substr(n, 2, pos('.', n, 3)-2)
if cl \== mapGet(d, h2) then
return err('csvInt: forward class' cl 'mismatches' line)
end
else do
if mapHasKey(m, d, h3) then
return err('already defined:' line)
if h1 == 'c' then do
do while datatype(right(h2, 1), 'n')
h2 = left(h2, length(h2)-1)
end
if h2 == '-' then
h2 = 'CsvForward'
s = ''
cl = classNew(copies('n*' h2' ', h2 \== '-')rr)
call classMet cl, 'new'
return mapAdd(d, h3, cl)
end
cl = mapGet(d, h2, '')
if cl == '' then
return err('undefined class:' line)
n = mNew(cl)
call mapAdd d, h3, n
end
call csv2o n, cl, rest
ff = classFldD(cl)
do fx=1 to m.ff.0
f1 = n || m.ff.fx
c1 = m.ff.fx.class
if m.c1 \== 'r' | m.f1 == '' | abbrev(m.f1, m.o_escW) then
iterate
t1 = mapGet(d, m.f1, '')
if t1 == '' then
return err('missing reference' fx m.f1 'in' line)
m.f1 = t1
end
if h1 == 'o' then do
if m.m.forward \== '' then
call err 'forward not empty:' line
call mAdd wStem, n
end
return
endProcedure csvInt
/* copy csv end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'" ,
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 <> 0" ,
"| m.qStem.0 < m.m.bufMax / 2 then do;" ,
"call mAddSt m''.BUF'', qStem;" ,
"if m.m.buf.0 > m.m.bufMax then do;" ,
"wStem = m''.BUF'';'" ,
"classMet(cl, 'jWriteMax')'; end; end;",
"else do; wStem = qStem;' classMet(cl, 'jWrite') ';end'",
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
return classInheritsOf(objClass(obj), sup)
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return true if obj is kind of string -------------------------*/
oKindOfString: procedure expose m.
parse arg obj
return objMet(obj, 'oKindOfString')
/*--- if obj is kindOfString return string
otherwise return arg(2) or fail ---------------------------*/
oAsString: procedure expose m.
parse arg m
interpret objMet(m, 'oAsString')
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=[...] -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
/* copy o end ********************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = ']'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "asString return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "asString return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=[''', ''']''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "oKindOfString return classMet(cl, 'asString', '\-\')" ,
"\== '\-\'" ,
, "oAsString if classMet(cl, 'oKindOfString')" ,
"then return classMet(cl, 'asString');",
"else return 'if arg() >= 2 then return arg(2)" ,
"; else return err(m ''is not a kind of string" ,
"but has class' className(cl)''')'" ,
, "o2String return classMet(cl,'asString','\-\')" ,
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
m.class_S = classNew('n String u', 'm',
, 'asString return m' ,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, "asString return ''",
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=['className(cl)']'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
call mPut class_inheritMet'.'m.class_V, 0
call mPut class_inheritMet'.'m.class_W, 0
call mPut class_inheritMet'.'m.class_O, 0
call mPut class_inheritMet'.'m.class_S, 0
call mPut class_inheritMet'.'m.class_N, 0
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0 /* methods directly in cl */
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0 /* inherited methods */
cl = m.aC.cx
if m.cl == 'u' & m.class_inheritMet.cl \== 0 then
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end **************************************************/
/* copy mapExp begin *************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ***************************************************/
/* copy map begin *****************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end ******************************************************/
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy fTab begin ****************************************************
output Modes: t = tableMode 1 line per object with fixed colums th
c = colMode 1 line per column/field of object
we build a format for each column
and a set of title lines, one sequence printed before
, one sequence printed after
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * fTabAdd * add col info
sqlFTabOthers ?
fTabGenTab or fTabGenCol
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
primary data for each col
.col : column (rexx) name plus aDone
.done : == 0 sqlFtabOthers should add it again
.fmt : format
.labelLo : long label for multi line cycle titles
.labelSh : short label for singel title line (colwidth)
.tit.* : title line piece for this col
**********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.verbose = pos('s', m.m.opt) < 1 /* not silent */
m.m.0 = 0
m.m.set.0 = 0
return fTabResetCols(oMutate(m, m.fTab_class))
endProcedure fTabReset
/*--- clean out all cols of ftab, but keep settings -----------------*/
fTabResetCols: procedure expose m.
parse arg m
m.m.0 = 0
return m
/*--- for column cx set title tx ------------------------------------*/
fTabSetTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if tx > m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabSetTit
/*--- set default atts for a col name ------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, sh, lo
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelSh = sh
m.m.set.sx.labelLo = lo
m.m.set.c1 = sx
return
endProcedure fTabSet
/*--- add a column --------------------------------------------------
m, rexxName done, fmt, labelShort, labelLong, titles... ------*/
fTabAdd: procedure expose m.
parse arg m, rxNm aDone
m.m.generated = ''
cx = m.m.0 + 1
m.m.0 = cx
cc = m'.'cx
m.cc.col = rxNm
m.cc.done = aDone \== 0
parse arg , , m.cc.fmt, m.cc.labelSh, m.cc.labelLo
if rxNm == '=' | rxNm == 0 | rxNm == 1 then
call err 'bad rxNm' rxNm
if \ (aDone == '' | aDone == 0 | aDone == 1) then
call err 'bad aDone' aDone
m.cc.tit.0 = max(arg()-4, 1)
m.cc.tit.1 = ''
do tx=2 to m.cc.tit.0
m.cc.tit.tx = arg(tx+4)
end
return cc
endProcedure fTabAdd
/*--- complete column info-------------------------------------------*/
fTabColComplete: procedure expose m.
parse arg m
do cx=1 to m.m.0
nm = m.m.cx.col
f1 = m.m.cx.fmt
if f1 = '' then
m.m.cx.fmt = '@.'nm'%-8C'
else do
px = pos('%', f1)
ax = pos('@', f1)
if px > 0 & (ax <= 0 | ax >= px) then
m.m.cx.fmt = left(f1, px-1)'@.'nm || substr(f1, px)
end
if m.m.cx.labelLo = '' then
if nm = '' then
m.m.cx.labelLo = '='
else
m.m.cx.labelLo = nm
if m.m.cx.labelSh = '' then
m.m.cx.labelSh = m.m.cx.labelLo
end
return
endProcedure fTabColComplete
/*--- generate line formats and title lines -------------------------*/
fTabGenTab: procedure expose m.
parse arg m, sep
if m.m.generated == '' then
call fTabColComplete m
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
f = ''
tLen = 0
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelSh
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelSh) < 1 then /* corrupted| */
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelSh, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fGen('%>', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
/*try with cycle lines for cSta to cEnd */
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelLo
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelLo
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelLo) ,
= translate(m.m.kx.labelSh)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenTab
/*--- generate column format ----------------------------------------*/
fTabGenCol: procedure expose m.
parse arg m
if m.m.generated == '' then
call fTabColComplete m
do kx=1 to m.m.0
t = m.m.kx.labelLo
l = if(m.m.kx.labelSh == t, , m.m.kx.labelSh)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabGenCol
/*--- output all of rdr in tab format -------------------------------*/
fTab: procedure expose m.
parse arg m, rdr
if pos('a', m.m.opt) < 1 then
i = rdr
else do
i = in2Buf(rdr)
if m.i.buf.0 > 0 then
call fTabDetect m, i'.BUF'
end
if pos('o', m.m.opt) > 0 then do
call pipeWriteAll i
end
else if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
i = jOpen(in2file(i), '<')
do rx=1 while jRead(i)
call out left('--- row' rx '', 80, '-')
call fTabCol m, m.i
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
call jClose i
end
else do
call fTabBegin m
call fAll m.m.fmt, i
return fTabEnd(m)
end
return m
endProcedure fTab
/*--- output object i in col format ---------------------------------*/
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenTab m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr
if m == '' then
m = fTabReset(f_auto, 1, , 'a')
else if pos('a', m.m.opt) < 1 then
m.m.opt = 'a'm.m.opt
return fTab(m, rdr)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
do cx=1 to m.m.0
rxNm = m.m.cx.col
done.rxNm = m.m.cx.done
if m.m.cx.fmt == '' then
m.m.cx.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
rxNm = substr(m.ff.fx, 2)
if done.rxNm \== 1 then do
cc = fTabAdd(m, rxNm)
m.cc.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabDetectFmt: procedure expose m.
parse arg st, suf
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
return '%'newFo
endProcedure fTabDetectFmt
/* copy fTab end ***************************************************/
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"["pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF']' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '[' plus
parse var aMid aLen '.' aPrec
if pos(']', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF']'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: ------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_uc25 = left(m.ut_uc, 25)
m.ut_alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/