zOs/REXX/EXCSM
/* rexx ----------------------------------------------------------------
csm examples |||||||| include neue incs ||||||
functions:
inAppc: get cidvar um convId zu holen, sind wir unter csmAppc?
sub rz? : submit localt/oder remote job
stAppc : start a this rexx locally under csmAppc, continue
del rz dsn: delete dsn
dsList rz mask?: datset liste
mbrList rz pds? mask=?: member Liste
mbrList rz pds? mask=?: member Liste
copy rz pds? mbr?: read into stem and show lines
sql rz dbSys: send an sql using csmASql
???? exe rz cmd: execute rexx on remote rz
----------------------------------------------------------------------*/
call errReset hi
parse arg mArg
/* mArg = 'del rz1 DSN.ABUB.AAA.DBTF.ERRX.D14013.T135604' */
if mArg = '' then
address isrEdit 'macro (mArg)'
if mArg = '' & 1 then do
mArg = "csmCopy 'rz4/A540769.wk.rexx(exCsm)', " ,
"'rz1/A540769.tmp.nnnn(qrst)'"
mArg = "csmCopy 'rz4/A540769.tmp.seq', " ,
"'rz1/A540769.tmp.nnnn(q)'"
mArg = "csmCopy 'A540769.wk.rexx', " ,
"'rz1/A540769.tmp.ttt'"
end
if mArg = '' then
exit errHelp('no input')
else if pos('?', mArg) > 0 then
exit help()
m.workLevel = 0
exit work(mArg)
work: procedure expose m.
parse arg mProc mArgs
if mProc = '' then
return
wLevel = m.workLevel + 1
m.workLevel = wLevel
rc = '?'
result = '?'
say 'exCsm' wLevel 'calling' mProc mArgs
interpret 'call' mProc mArgs
say 'exCsm' wLevel 'rc='rc 'result='result 'after call' mProc
return 0
endProcedure work
/*--- get cvidvar: conversation id -----------------------------------*/
inAppc: procedure expose m.
parse arg silent cont
if silent \== 0 & silent \==1 then
parse arg cont
cvId = '???'
call csmAppc 'get cvidvar(convId)', '*'
m.inAppc = wordPos(rc, 0 25) > 0
if silent \== 1 then do
say 'get cvidvar rc='rc '--->inAppc='m.inAppc
say 'appc_cvid ='appc_cvid
say ' cvid ='cvid
do y=0 to appc_msg.0
say 'appc_msg.'y' ='appc_msg.y
end
say 'appc_state_c ='appc_state_c
say 'appc_state_f ='appc_state_f
say 'appc_ddName ='appc_ddName
say 'appc_llu ='appc_llu
say 'appc_plu ='appc_plu
end
call work cont
return m.inAppc
endProcedure inAppc
/*--- submit local oder remote ---------------------------------------*/
sub: procedure expose m.
parse arg rz
jn = userid()'S'
say 'submitting job' jn 'to' rz
I.1 = '//'jn 'JOB (CP00,KE50),NOTIFY=&SYSUID'
I.2 = '//*MAIN CLASS=LOG0 ' time()
I.3 = '//* from' sysvar(sysnode) 'at' time() 'submit to' rz
I.4 = '//S1 EXEC PGM=IEFBR14'
if rz = '' | rz = sysvar(sysNode) then
call adrTso 'alloc dd(sub) sysout writer(intRdr)'
else /* mit freeClose braeuchte es keine Free */
call adrCsm 'allocate system('rz') sysout(T) writer(intRdr)',
'ddName(sub)'
/* call tsoOpen 'sub', 'w' */
call writeDD 'sub', i., 4
call tsoClose 'sub'
call adrTso 'free dd(sub)' /* csmExec free macht dasselbe */
return
endProcedure sub
/*--- start a rexx locally under csmAppc -----------------------------*/
stAppc: procedure expose m.
parse arg cont
return csmAppc("start pgm(csmexec)",
"Parm('Select Cmd(''%exCsm" cont"'')')", '*')
return
endProcedure stAppc
/*-- dataset list ----------------------------------------------------*/
dsList: procedure expose m.
parse arg rz dir
if dir = '' then
dir = userid()
if pos('*', dir) < 1 then
dir = dir'.**'
lc = adrCsm('dslist system('rz') dsnMask('dir') short')
say 'dsList' rz dir 'rc='lc 'stemSize='stemSize
do sx=1 to stemsize
if sx > 10 then
sx = min(2*(sx-1), stemSize)
say sx dsName.sx strip('vol='volume.sx','volume2.sx) ,
'sys='sysName.sx
end
return 0
endProcedure dsList
/*-- member list ----------------------------------------------------*/
mbrList: procedure expose m.
parse arg rz lib msk
if lib = '' then
lib = A540769.WK.REXX
if msk = '' then
msk = '*'
lc = adrCsm("mbrList system("rz") dataset('"lib"') member("msk")",
"index(' ') short")
say 'mbrList' rz lib'('msk')' 'rc='lc 'mbr_name.0='mbr_name.0
do sx=1 to mbr_name.0
if sx > 10 then
sx = min(2*(sx-1), mbr_name.0)
say sx mbr_Name.sx
end
return 0
endProcedure dsList
/*-- member list ----------------------------------------------------*/
copy: procedure expose m.
parse arg fr to
if lib = '' then do
lib = A540769.WK.REXX
mbr = 'exCsm'
end
call adrCsm "allocate system("rz") dataset('"lib"')" ,
"ddName(cpy) disp(shr) dsinfo"
say 'alloc' rc 'subsys... _dataset' ,
'dsorg('subsys_dsOrg')' ,
'mgmtClas('subsys_mgmtClas')' ,
'dsnType('subsys_rDsnType')' ,
'dataClas('subsys_dataClas')' ,
'recFM('strip(translate('1 2 3', subsys_recFm, '123'))')',
'lRecl('subsys_lRecl')' ,
'space('subsys_spacePri',' subsys_spaceSec')' ,
subsys_spacUnit || left('S', subsys_spacUnit == 'CYLINDER')
c = "copy inDD(cpy)"
if mbr <> '' then
c = c "member("mbr")"
lc = adrCsm(c 'stemout(st)', '*')
say c 'rc='lc 'st.0='st.0
call adrCsm "free ddName(cpy)"
do sx=1 to st.0
if sx > 10 then
sx = min(2*(sx-1), st.0)
say sx':' strip(st.sx, 't')
end
return 0
endProcedure dsList
del: procedure expose m.
parse arg rz dsn
say 'delete '''dsn''' in' rz
mb = dsnGetMbr(dsn)
if mb \== '' then do
mb = 'member('mb')'
call err 'csm deletes library, although member is specified|||'
end
call adrCsm "allocate system("rz") dataset('"dsnSetMbr(dsn)"')" ,
mb "disp(del) ddname(del1)"
say 'allocated with disp(del)'
call readDD del1, i., '*'
say 'read' i.0 'records 1:' strip(i.1)
i0 = i.0
say ' 'i0':' strip(i.i0)
call tsoClose del1
call adrTso 'free dd(del1)'
say 'tso free done'
return
endProcedure del
/*--- send an sql to csmASql and fetch result ------------------------*/
sql: procedure expose m.
parse upper arg rz dbSys
sql_query = 'select current server "srv", current member "mbr"' ,
', current timestamp',
'from sysibm.sysDummy1'
sql_host = rz
sql_db2ssid = dbSys
call csmAppc "START PGM(CSMASQL)"
say 'csmASql rc='rc 'sqlCode' sqlCode 'sql_message.0='sql_message.0
Do I = 1 To SQL_Message.0
Say SQL_Message.I
End
say 'sqlCode='sqlCode 'sqlErrm='sqlErrm
say 'sqlD='sqlD 'sqlRow#='sqlRow#
say 'sql_option='sql_option ,
'sql_cvid='sql_cvid 'sqlcvid='c2x(sqlcvid)
/* describe result */
Do I = 1 To Sqld
Say Right(I,2) 'sqlda_*.'i 'name='strip(Sqlda_Name.I),
'rexxname='strip(Sqlda_Rexxname.I),
'type='strip(Sqlda_Type.I),
'types='space(Sqlda_Types.I, 1),
'len='sqlda_Len.I
End
/* content of result */
Do I = 1 To Sqlrow#
Say 'Indicator:'I C2x(Sqlindicator.i)
Do J = 1 To Sqld
Say Left(J' 'Sqlda_Name.J,23) ,
sqlda_rexxName.j'.'i'='Value(Sqlda_Rexxname.J'.'I)
End
End
return
endProcedure sql
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01 ------------------------------------*/
exe: procedure expose m.
parse arg rz cmd.1
cmd.0 = 1
if 1 then do
call adrTso 'free dd(rmtSys)' ,'*'
call adrTso 'free dd(rmtsPrt)','*'
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
if cmd.1 = '' then do
cmd.1 = '%exArgs eins zwei from' sysvar(sysnode) 'to' rz'|'
cmd.2 = '%exArgs zwei laaaangeeeeeeeeeeeeeeeeeeeeeeee-'
cmd.3 = left('',70,'f')'-'
cmd.4 = left('',70, 'g')'|'
cmd.5 = '%exArgs drei fertig schlus|'
cmd.0 = 5
end
call dsnAlloc 'dd(DDCPARM) dummy'
f = dsnAlloc('dd(tsin) new ::f')
f = dsnAlloc('dd(printout) new ::f')
call writeDD tsin, cmd.
call writeDDClose tsin
call adrCms 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrTso "ex 'SM.RZ1.P0.CSM.COMMON.EXEC(TPSYSIKJ)'",
"'"rz";"csm";600'", '*'
say 'exe after remote ex tpSysiKJ rc='rc
call readDD 'printout', p.
say 'read printout' p.0 'lines'
do px=1 to p.0
say p.px
end
call tsoFree 'DDCPARM tsin printout'
call adrTso 'free dd(rmtSys rmtsPrt rmtsIn sysproc)'
say 'exe after free rc='rc 'result='result
return
endProcedure exe
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
exDi: procedure expose m.
parse arg rz cmd.1
if cmd.1 = '' then
cmd.1 = '%exArgs eins zwei from' sysvar(sysnode) 'to' rz'|'
timeout = 11
if 0 then do
call adrTso 'free dd(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
cmd.1 = '%exArgs' cmd 'from' sysvar(sysnode) 'to' rz'|'
call writeDD rmTsIn, cmd., 1
call writeDDClose rmtsin
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call csmAppc "start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
call csmAppcRcSay ggTsoCmd
call readDD 'rmTsPrt', p.
say p.0
do px=1 to p.0
say p.px
end
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtSys rmtsIn sysproc)'
return
endProcedure exdi
/*--- start dlg2 locally under csmAppc -------------------------------*/
dlg1: procedure expose m.
parse arg rz
call csmAppc "START PGM(CSMEXEC)",
"Parm('Select Cmd(''%exCsm dlg2 ''''" rz "'''''')')"
return
endProcedure dlg1
/*--- dialog with a rexx (under tso) in another rz
this is only possible under csmAppc| -----------------------*/
dlg2: procedure expose m.
parse arg rz cmd
timeout = 81
if 1 then do
call adrTso 'free dd(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a'), '*'
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCms 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
cmd.1 = "%exCsm dlg3 '" cmd "from" sysvar(sysnode) "to" rz"|'"
call writeDD rmTsIn, cmd., 1
call writeDDClose rmtsin
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrCms 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrtso "csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) timeout("timeOut")", '*'
say 'alloc rc='rc appc_rc 'rea' appc_reason 'cvid' appc_cvid
pId = appc_cvid
call csmAppcRcSay ggTsoCmd
buf = 'erstes send' time() 'von dlg2'
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(2)", '*'
call csmAppcRcSay ggTsoCmd
buf = 'zweites send' time() 'von dlg2 soso'
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
call csmAppc "receive cvid(x'"pId"') buffer(BUF)", '*'
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
call csmAppc "DEALLOC CVID(X'"pId"') TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
call readDD 'rmTsPrt', p.
say p.0
do px=1 to p.0
say p.px
end
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtSys rmtsIn sysproc)'
return
endProcedure dlg2
dlg3: procedure expose m.
parse arg args
say 'dlg3('args')'
call csmAppc 'GET CVIDVAR(var)', '*'
call csmAppcRcSay ggTsoCmd
say ' appc_DD='appc_ddName 'llu='appc_llu 'plu='appc_plu
pId = appc_cvid
call csmAppc "receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
call csmAppc "receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
buf = 'antwort von dlg3' args 'um' time() 'an dlg2 auf:' buf
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
return
endProcedure dlg3
/*--- start sqlUOW2 locally in csmAppc -------------------------------*/
sqlUOW1: procedure expose m.
parse arg rz dbSys .
call csmAppc "START PGM(CSMEXEC)",
"Parm('Select Cmd(''%exCsm sqlUow2 ''''"rz dbsys"'''''')')"
return
endProcedure sqlUow1
/*--- do muliple sql in a single transaction
this works only in a csmAppc Environment| -----------------*/
sqlUOW2: procedure expose m.
parse arg rz dbSys .
drop sql_cvid
sql_option = 'R'
/* send an sql to csmASql and fetch result */
call sendSql rz, dbSYs,
, 'declare global temporary table session.dgt',
'(id int, name char(20))'
if m.inAppc then /* otherwise sqlCvid is invalid */
sql_cvid = sqlCvid
call sendSql rz, dbSYs,
, "insert into session.dgt values(17, 'inserted17')"
call sendSql rz, dbSYs,
, "select * from session.dgt"
return
endProcedure squUOW2
exit
????????????????????????????
parse arg mm vv
say csmSub mm vv
mark = 'csmExec'
if mm <> mark then do
c = "csmExec select cmd('csmSub" mark mm vv"')"
say c
call adrTso c
exit
end
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg aFr, aTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
fr = csmSysDsn(aFr)
frMbr = dsnGetMbr(fr)
frDD = tsoDD('csmFr*', 'a')
to = csmSysDsn(aTo)
toMbr = dsnGetMbr(to, '=')
toDD = tsoDD('csmTo*', 'a')
call csmAlloc dsnSetMbr(fr) frDD 'shr'
if frMbr == '' & m.tso_ddDsOrg.frDD == 'PO' then
if toMbr \== '=' then
call err 'csmCopy from' fr'(*) to ps' to
else
frMbr = '*'
if frMbr == '' & (toMbr \== '' & toMbr \== '=') then
psOrLib = 'dsorg(po) dsntype(library)'
else if frMbr \== '' & toMbr == '' then
psOrLib = 'dsorg(ps)'
else
psOrLib = ''
call csmAlloc dsnSetMbr(to) toDD 'shr ::D'frDD psOrLib
c = 'indd('frDD') outDD('toDD')'
if frMbr \== '*' then do
if frMbr \== '' then
c = c 'member('frMbr')'
if toMbr \== '' & toMbr \== '=' then
c = c 'newName('toMbr')'
call adrCsm 'copy' c
end
else do
call adrCsm "mbrList ddName("frDD") index(' ') short"
say '???copying' mbr_mem# 'members'
do mx=1 to mbr_mem#
say mx '????copy' c 'member('mbr_name.mx')'
call adrCsm 'copy' c 'member('mbr_name.mx')'
end
end
call tsoFree frDD toDD
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
upper dd disp
m.tso_dd.dd = csmSysDsn(dsn)
parse var m.tso_dd.dd sys '/' dsn
if disp = '' then
disp = 'shr'
a1 = "SYSTEM("sys") DDNAME("dd")"
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")"
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts( , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
say '???uCount ==>' rest
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
say '???recfm ==>' rest
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
say '???cylinders ==>' rest
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
say '???cyl ==>' rest
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_ddDsOrg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc m.tso_dd.dd dd 'CAT' rest ':'nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsn')')
if stemsize <> 1 then
call err 'cmsLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
'dataClas('dataClas.1')' ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
say '???csmLike' rz'/'dsn '==>' r
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX'
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 11
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy 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 arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
call outtrap m.tso_trap.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'O' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'A' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.tso_trap.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.tso_dd.dd"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt tso_trap
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/