zOs/REXX/PRB
/* rexx ---------------------------------------------------------------
edit macro fuer prb Columns 8.11.13 kidi 63
Walter Keller
line Commands
d: replace deleted lines with generate columns
a: b: add generated columns there
Options in First word of argument
g: tacct_general table (default)
p: tacct_program table
s: sum on numeric columns
e: fosFmte7 on numeric columns plus totals
n: add all numeric columns (not just the short list)
r: surround numeric columns with real
c: add all not numeric columns
second and following (space separated) words of argument
a<alias>: alias (default g)
e<expr> : sql expression with ~(tilde) placeHolder for current column
8.11.13 walter r=real option added to avoid fixpoint overflow
----------------------------------------------------------------------*/
call errReset hi
call mapIni
call adrEdit 'macro (args) NOPROCESS'
if pos('?', args) > 0 then
return help()
pc = adrEdit("process dest range D", 0 4 8 12 16)
if pc = 16 then
call err 'Only A or B line expected, \n ' ,
'You entered incomplete or conflicting line commands'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
m.dst = rFi - 1
call adrEdit 'delete' rFi rLa
end
if pc = 0 | pc = 4 then do
call adrEdit "(d1) = lineNum .zDest", 0 4
m.dst = d1 /* rc=4 ist lineNum 0| */
end
if pc = 12 then do
call adrEdit "(c1, c2) = cursor"
m.dst = c1
end
call addLine '-- begin prb insert' args
parse var args arg1 argR
argR = ' 'argR
if pos('p', arg1) > 0 then
tb = 'program'
else
tb = 'general'
txt = '-- tacct_'tb
i = mapInline('prb_'tb)
m.alias = left(tb, 1)
cx = pos(' a', argR)
if cx > 0 then
m.alias = word(substr(argR, cx+2), 1)
txt = strip(txt m.alias)','
if m.alias \== '' then
m.alias = m.alias'.'
m.e7 = pos('e', arg1) > 0
if m.e7 then
txt = txt 'fsoFmtE7,'
allNum = pos('n', arg1) > 0
notNum = pos('c', arg1) > 0
txt = txt word('short all', allNum + 1)','
m.expr = '~'
cx = pos(' e', argR)
if cx > 0 then
m.expr = word(substr(argR, cx+2), 1)
if pos('r', arg1) > 0 then
m.expr = repAll(m.expr, '~', 'real(~)')
if pos('s', arg1) > 0 then
m.expr = 'sum('m.expr')'
if length(txt m.expr) > 65 then do
call addLine txt
txt = '-- '
end
call addLine txt 'expr' m.expr
listExt = 0
do ix=1 to m.i.0
if abbrev(word(m.i.ix, 1), '*') then do
listExt = 1
iterate
end
parse var m.i.ix cNo col typ len 52 as 62
if cNo == 'f' then do
as = subWord(m.i.ix, 3)
fArgs = CLines()
if m.e7 then
call addFunction col, fArgs, as
iterate
end
if cNo == '+' then do
fArgs = CLines()
if m.e7 then
call addPlus typ, fArgs, as
iterate
end
if wordPos(typ, 'REAL FLOAT INTEGER SMALLINT DECIMAL') ,
< 1 then do
if notNum then
call addLine ' ,' haCol('as', col, as)
iterate
end
if listExt & (c.col == 1 | \ allNum) then
iterate
c.col = 1
call addLine ' ,' haCol('ages', col, as)
end
call addLine '-- end prb insert' args
exit
/*--- read all following c lines and return its words ---------------*/
cLines: procedure expose m. i ix
r = ''
do ix=ix+1 to m.i.0 while abbrev(m.i.ix, 'c ')
r = r strip(substr(m.i.ix, 3))
end
ix = ix - \ abbrev(m.i.ix, 'c ')
return r
endProcedure cLines
/*--- handle one column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
haCol: procedure expose m.
parse arg opts, col, as
r = col
if pos('a', opts) > 0 then
r = m.alias || r
r1 = r
if pos('g', opts) > 0 then
r = repAll(m.expr, '~', r)
if pos('e', opts) > 0 & m.e7 then
r = 'fosFmtE7('r')'
if pos('s', opts) > 0 then
if m.e7 & as \== '' then
r = r '"'strip(as)'"'
else if r1 <> r then
r = r col
return r
endProcedure haCol
/*--- handle non numeric column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addFunction: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t',' haCol('ag', word(aCols, ax))
end
t = fun'('substr(t, 3)') "'strip(as)'"'
call addLineSplit t, ','
return
endProcedure addFunction
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addPlus: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t '+' haCol('a', word(aCols, ax))
end
t = haCol('g', '('substr(t, 4)')')
if fun == '-' then
t = haCol('e', t)
else
t = strip(fun)'('t')'
call addLineSplit t '"'strip(as)'"', '+'
return
endProcedure addPlus
addLine: procedure expose m.
parse arg li
call adrEdit "line_after" m.dst " = (li)"
m.dst = m.dst + 1
return
endProcedure addLine
addLineSplit: procedure expose m.
parse arg src, spl
r = ' ,' src
do while length(r) > 70
lx = lastPos(spl, r, 70)
call addLine left(r, lx-1)
r = ' ' substr(r, lx)
end
call addLIne r
return
endProcedure addLIneSPlit
$</prb_general/
*** PBDD.TACCT_GENERAL
32 ELAPSETOD FLOAT 8 totElap
33 ELAPSETCB FLOAT 8 totCPU
37 EDB2TOD FLOAT 8 db2Elap
38 EDB2TCB FLOAT 8 db2CPU
f fosGeWait wait % 1. % 2. % 3.
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
+ - - sqls
c p2Commits aborts
c selects inserts updates deletes
c describes prepares opens fetches closes
c setcurprec dclglobaltt sqlcrgtt
35 P2COMMITS FLOAT 8 commit
36 ABORTS FLOAT 8 abort
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
86 LOGWRTELAP FLOAT 8 logEla
88 LOGRECORDS FLOAT 8 logRecs
89 LOGBYTES FLOAT 8 logByte
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
+ - REAL wait
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
*** PBDD.TACCT_GENERAL
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 LUWIDNID CHAR 8
10 LUWIDLUNM CHAR 8
11 LUWIDINST CHAR 6
12 LUWIDCOMIT FLOAT 8
13 CONNTYPE CHAR 8
14 DATETIME TIMESTMP 10
15 DATE DATE 4
16 LOCATION CHAR 16
17 GROUPNAME CHAR 8
18 FIRSTPKG CHAR 18
19 ACCTTOKN CHAR 22
20 ENDUSERID CHAR 16
21 ENDUSERTX CHAR 32
22 ENDUSERWN CHAR 18
23 PSTNUMBER CHAR 4
24 PSBNAME CHAR 8
25 CICSTRAN CHAR 4
26 CORRNAME CHAR 8
27 NETWORKID CHAR 16
28 TRANSCNT FLOAT 8
29 CLASS2CNT FLOAT 8
30 CLASS3CNT FLOAT 8
31 IFCIDSEQ# FLOAT 8
32 ELAPSETOD FLOAT 8
33 ELAPSETCB FLOAT 8
34 ELAPSESRB FLOAT 8
35 P2COMMITS FLOAT 8
36 ABORTS FLOAT 8
37 EDB2TOD FLOAT 8
38 EDB2TCB FLOAT 8
39 EDB2SRB FLOAT 8
40 EWAITIO FLOAT 8 synIOWait
41 EWAITLAL FLOAT 8 locLoLaWait
42 ENTEXEVNT FLOAT 8
43 WAITEVNT FLOAT 8
44 WAITREADIO FLOAT 8 othReaWait
45 WAITWRITEIO FLOAT 8 othWriWait
46 WAITSYNCEVENT FLOAT 8 uniSwiWait
47 WAITARCLOG FLOAT 8 arcLogWait
48 WEVLOCK FLOAT 8
49 WEVREAD FLOAT 8
50 WEVWRITE FLOAT 8
51 WEVSYNCH FLOAT 8
52 CLASS1CPU_ZIIP FLOAT 8
53 CLASS2CPU_ZIIP FLOAT 8
54 TRIGGERCPU_ZIIP FLOAT 8
55 CPUZIIPELIGIBLE FLOAT 8
56 ARCLOG FLOAT 8
57 DRAINLKRND FLOAT 8
58 DRAINLKWDR FLOAT 8 drainWait
59 CLAIMRLWCL FLOAT 8 claimWait
60 CLAIMRLRNC FLOAT 8
61 ARCHREADWAR FLOAT 8 arcReaWait
62 ARCHREADNAR FLOAT 8
63 OPENCLSELAP FLOAT 8 opeCloWait
64 SYSLGRNGELAP FLOAT 8 sysLgRaWait
65 DATASETELAP FLOAT 8 datSetWait
66 OTHERSWELAP FLOAT 8 othSwiEla
67 OPENCLSEVNT FLOAT 8
68 SYSLGRNGEVNT FLOAT 8
69 DATASETEVNT FLOAT 8
70 OTHERSWEVNT FLOAT 8
71 LATCHCNTWTP FLOAT 8
72 LATCHCNTRNH FLOAT 8
73 GBLMSGELAP FLOAT 8 gblMsgWait s
74 GBLMSGEVNT FLOAT 8
75 GBLLOKELAP FLOAT 8 gblConWait s
76 GBLLOKEVNT FLOAT 8
77 SPTCB FLOAT 8 stoProCpu c1 nurWLM
78 SPTCBINDB2 FLOAT 8 stoProDb2 c2
79 SPEVNT FLOAT 8
80 SPWAITELAP FLOAT 8 stoProWait
81 SPWAITCNT FLOAT 8
82 PARATASKS FLOAT 8
83 PARALLTASKS FLOAT 8
84 CPUSUCONV FLOAT 8
85 LOGWRTEVNT FLOAT 8
86 LOGWRTELAP FLOAT 8 logWrtWait
87 WLMSVCCLASS CHAR 8
88 LOGRECORDS FLOAT 8
89 LOGBYTES FLOAT 8
90 FUNCTCB FLOAT 8 funcCpu c1 cpu
91 FUNCSQLTCB FLOAT 8 funcD2Cpu c2 cpu
92 FUNCSQLEVNT FLOAT 8
93 LOBWAITCNT FLOAT 8
94 FUNCWAIT FLOAT 8 funcWait
95 FUNCELAP FLOAT 8 funcEla c1 ela
96 FUNCSQLELAP FLOAT 8 funcD2Ela c2 ela
97 TRIGGERTCB FLOAT 8 triD2Cpu
98 TRIGGERELAP FLOAT 8 triD2Ela
99 PREENCTCB FLOAT 8 ???
100 PREENCSQLTCB FLOAT 8 ???
101 SPROCELAP FLOAT 8 stoProToEla
102 SPROCSQLELAP FLOAT 8 stoProD2Ela
103 ENCTRIGGERTCB FLOAT 8 triNesToCpu
104 ENCTRIGGERELAP FLOAT 8 triNesToEla
105 LOBWAITELAP FLOAT 8
106 SPNFCPUZIIP FLOAT 8 ???
107 SPNFCPU FLOAT 8 ???
108 SPNFELAP FLOAT 8 ???
109 UDFNFCPUZIIP FLOAT 8
110 UDFNFCPU FLOAT 8
111 UDFNFELAP FLOAT 8
112 SVPOINTREQ FLOAT 8
113 SVPOINTREL FLOAT 8
114 SVPOROLLBK FLOAT 8
115 WTELAWTK FLOAT 8 gblChiWait
116 WTELAWTM FLOAT 8 gblOtLWait
117 WTELAWTN FLOAT 8 gblPrPWait
118 WTELAWTO FLOAT 8 gblPgPWait
119 WTELAWTQ FLOAT 8 gblOtPWait
120 WTEVARNK FLOAT 8
121 WTEVARNM FLOAT 8
122 WTEVARNN FLOAT 8
123 WTEVARNO FLOAT 8
124 WTEVARNQ FLOAT 8
125 WTELAWFC FLOAT 8 ???
126 WTEVFCCT FLOAT 8
127 WTELIXLT FLOAT 8
128 WTEVIXLE FLOAT 8
129 SETCURPREC FLOAT 8
130 DCLGLOBALTT FLOAT 8
131 PARAGLOBALTT FLOAT 8
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
141 PARAMAXDEG FLOAT 8
142 PARAREDGRP FLOAT 8
143 SQLCALLAB FLOAT 8
144 SQLCALLTO FLOAT 8
145 SQLCRGTT FLOAT 8
146 REOPTIMIZE FLOAT 8
147 DIRECTROWIX FLOAT 8
148 DIRECTROWTS FLOAT 8
149 FUNC FLOAT 8
150 FUNCAB FLOAT 8
151 FUNCTO FLOAT 8
152 FUNCRJ FLOAT 8
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
162 DEADLOCKS FLOAT 8
163 SUSPENDS FLOAT 8
164 TIMEOUTS FLOAT 8
165 LOCKESHR FLOAT 8
166 LOCKEXCL FLOAT 8
167 MAXPGLOCKS FLOAT 8
168 SUSPLATCH FLOAT 8
169 SUSPOTHER FLOAT 8
170 LOCKREQS FLOAT 8
171 CLAIMREQ FLOAT 8
172 CLAIMREQUN FLOAT 8
173 DRAINREQ FLOAT 8
174 DRAINREQUN FLOAT 8
175 GBPREADINVBD FLOAT 8
176 GBPREADINVBR FLOAT 8
177 GBPREADNOPGD FLOAT 8
178 GBPREADNOPGR FLOAT 8
179 GBPREADNOPGN FLOAT 8
180 GBPWRITCHG FLOAT 8
181 GBPWRITCLEAN FLOAT 8
182 GBPUNREGPG FLOAT 8
183 GBPEXPLICITXI FLOAT 8
184 GBPWRITCHK2 FLOAT 8
185 GBPASYNPRIM FLOAT 8
186 GBPASYNSEC FLOAT 8
187 GBPDEPGETPG FLOAT 8
188 GBPPLKSPMAP FLOAT 8
189 GBPPLKDATA FLOAT 8
190 GBPPLKIDX FLOAT 8
191 GBPPLKUNLK FLOAT 8
192 GBPPSUSSPMAP FLOAT 8
193 GBPPSUSDATA FLOAT 8
194 GBPPSUSIDX FLOAT 8
195 GBPWARMULTI FLOAT 8
196 GBPWAR FLOAT 8
197 GLPLOCKLK FLOAT 8
198 GLPLOCKCHG FLOAT 8
199 GLPLOCKUNLK FLOAT 8
200 GLXESSYNCLK FLOAT 8
201 GLXESSYNCCHG FLOAT 8
202 GLXESSYNCUNLK FLOAT 8
203 GLSUSPIRLM FLOAT 8
204 GLSUSPXES FLOAT 8
205 GLSUSPFALSE FLOAT 8
206 GLINCOMPAT FLOAT 8
207 GLNOTFYSENT FLOAT 8
208 GLFALSECONT FLOAT 8
209 RLFCPULIMITU FLOAT 8
210 RLFCPUUSEDU FLOAT 8
211 UNLOCKREQS FLOAT 8
212 QUERYREQS FLOAT 8
213 CHNGREQS FLOAT 8
214 IFIELAPSED FLOAT 8
215 IFITCBCPU FLOAT 8
216 IFIELAPDTC FLOAT 8
217 IFIELAPEXT FLOAT 8
218 PROGRAMS FLOAT 8
219 LOADTS TIMESTMP 10
$/prb_general/
$</prb_program/
*** PBDD.TACCT_PROGRAM
27 ELAPSEPKG FLOAT 8 pkgElap
28 CPUTCBPKG FLOAT 8 pkgCpu
46 CLASS7CPU_ZIIP FLOAT 8 pkgZIIP
f fosPrWait wait % 1. % 2. % 3.
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
52 BPGETPAGE FLOAT 8 bpGetPg
53 BPPGUPDAT FLOAT 8 bpUpdPg
54 BPSYNCRD FLOAT 8 bpSynRe
75 SQLCALL FLOAT 8
26 SQLCOUNT FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8 describ
71 PREPARES FLOAT 8 prepare
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
+ - real wait
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
*** all of PBDD.TACCT_PROGRAM
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 CONNTYPE CHAR 8
10 DATETIME TIMESTMP 10
11 DATE DATE 4
12 LOCATION CHAR 16
13 GROUPNAME CHAR 8
14 ENDUSERID CHAR 16
15 ENDUSERTX CHAR 32
16 ENDUSERWN CHAR 18
17 CORRNAME CHAR 8
18 CLASS7CNT FLOAT 8
19 CLASS8CNT FLOAT 8
20 IFCIDSEQ# FLOAT 8
21 CPUSUCONV FLOAT 8
22 EXECLOCATION CHAR 16
23 COLLECTIONID CHAR 18
24 PROGRAMNAME CHAR 18
25 CONSISTOKEN CHAR 16
26 SQLCOUNT FLOAT 8
27 ELAPSEPKG FLOAT 8
28 CPUTCBPKG FLOAT 8
29 ELAPSYNCIO FLOAT 8 syncIOW
30 ELPLOCK FLOAT 8
31 ELPOTHREAD FLOAT 8 othReaW
32 ELPOTHWRIT FLOAT 8 othWriW
33 ELPUNITSW FLOAT 8 unitSwW
34 ELPARCQIS FLOAT 8 arcLQuW
35 ELPDRAIN FLOAT 8 drainW
36 ELPCLAIM FLOAT 8 claimW
37 ELPARCREAD FLOAT 8 arcLReW
38 ELPPGLAT FLOAT 8 pgLatW
39 GBLMSGELAP FLOAT 8 glMsgW
40 GBLLOKELAP FLOAT 8 glLockW
41 SPWAITELAP FLOAT 8 stPrW
42 SPROCCNT FLOAT 8
43 FUNCWAIT FLOAT 8
44 FUNCCNT FLOAT 8
45 LOBWAITELAP FLOAT 8 lobW
46 CLASS7CPU_ZIIP FLOAT 8
47 WTELAWTK FLOAT 8 glChiW
48 WTELAWTM FLOAT 8 glOthW
49 WTELAWTN FLOAT 8 glPrtW
50 WTELAWTO FLOAT 8 glPgPhW
51 WTELAWTQ FLOAT 8 glOtPhW
52 BPGETPAGE FLOAT 8
53 BPPGUPDAT FLOAT 8
54 BPSYNCRD FLOAT 8
55 RLFCPULIMITU FLOAT 8
56 RLFCPUUSEDU FLOAT 8
57 SUSPLATCH FLOAT 8
58 SUSPOTHER FLOAT 8
59 LOCKREQS FLOAT 8
60 UNLOCKREQS FLOAT 8
61 QUERYREQS FLOAT 8
62 CHNGREQS FLOAT 8
63 IRLMREQS FLOAT 8
64 CLAIMREQ FLOAT 8
65 DRAINREQ FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8
71 PREPARES FLOAT 8
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
75 SQLCALL FLOAT 8
76 LOADTS TIMESTMP 10
$/prb_program/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
fmt = '%s%qn%s%qe%q^'fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mDigits = '0123456789'
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || m.mDigits
m.mAlfDot = m.mAlfNum || '.'
m.mBase64 = m.mAlfUC || m.mAlfLC || m.mDigits'+-'
m.mId = m.mAlfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.mPrint = m.mAlfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
verifId: procedure expose m.
parse arg src, extra, sx
if sx == '' then
sx = 1
if pos(substr(src, sx, 1), m.mDigits) > 0 then
return sx
else
return verify(src, m.mId || extra, 'n', sx)
endProcedure verifId
/* copy m end *********************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/