zOs/REXX.O08/SER
/*REXX *****************************************************************
serialise a list of PDS or other Dataset to a single stream
] mit einem ] am Anfang
]] mit zwei ] am Anfang
]]] mit drei ] am Anfang
***********************************************************************/
call serCreate '~zzz.backup(d'right(date(s), 6)')', ,
'~ WK.JCL wk.msgs wk.panels wk.pli wk.rexx wk.rexx.old' ,
'WK.SQL'
exit
call serOpen s, '~wk.texv(serTst1)'
call serAddDsn s, 'wk.rexx(ser)~'
call serAddPds s, 'wk.text(v*)~'
call serAdd s, '~ wk.text(a*) wk.rexx(sv)'
call serClose s
exit
serCreate: procedure
parse arg dst, list
call serOpen qq, dst
call serAdd qq, list
call serClose qq
return
endProcedure serCreate
serOpen: procedure expose m.
parse arg m, dsnSpec
if m.ser.ini <> 1 then do
m.ser.ini = 1
m.ser.next = 0
end
if symbol('m.ser.m.id') <> 'VAR' then do
nx = m.ser.next + 1
m.ser.next = nx
m.ser.m.id = nx
end
m.ser.m.dsns = 0
m.ser.m.rds = 0
m.ser.m.wrts = 0
alc = dsnAlloc(dsnSpec, 'OLD', 'SERW'm.ser.m.id)
m.ser.m.dd = word(alc, 1)
m.ser.m.ddClose = subword(alc, 2)
call writeDDbegin m.ser.m.dd
return
endProcedure serOpen
serClose: procedure expose m.
parse arg m
call writeDDend m.ser.m.dd
interpret m.ser.m.ddClose
say 'serialised' m.ser.m.dsns 'datasets with' m.ser.m.rds 'reads' ,
'and' m.ser.m.wrts 'writes'
return
endProcedure serClose
serAddDsn: procedure expose m.
parse arg m, dsnSpec
alc = dsnAlloc(dsnSpec, 'SHR', 'SERR'm.ser.m.id)
inDD = word(alc, 1)
dsn = dsnSpecDsn(dsnSpec)
call readDDbegin inDD
r.1 = ']beg' dsn
call writeDD m.ser.m.dd, r., 1
c = 0
do while readDD(inDD, r.)
c = c + r.0
do i=1 to r.0
if left(r.i, 1) = ']' then
r.i = ']'r.i
end
call writeDD m.ser.m.dd, r.
end
r.1 = ']end' dsn
call writeDD m.ser.m.dd, r., 1
call readDDend inDD
interpret subword(alc, 2)
m.ser.m.dsns = m.ser.m.dsns + 1
m.ser.m.rds = m.ser.m.rds + c
m.ser.m.wrts = m.ser.m.wrts + c + 2
return
endProcedure serAddDsn
serAddPds: procedure expose m.
parse arg m, dsnSpec
dsn = dsnSpecDsn(dsnSpec)
id = lmmBegin(dsnSpec)
do mx=0 by 1
mbr = lmmNext(id)
if mbr = '' then
leave
d1 = dsnSetMbr(dsn, mbr)
call serAddDsn m, d1
end
call lmmEnd id
say mx 'members in' dsn
return
endProcedure serPds
serAdd: procedure expose m.
parse arg m, list
ap = ''
upper list
do wx=1 to words(list)
w = word(list, wx)
if w == '~' then do
ap = w
iterate
end
dsn = dsnSpecDsn(ap || w)
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn)
lr = listDsi("'"pds"'")
if lr <> 0 then
call err "rc" lr "for listDsi('"pds"'):" sysReason
else if left(sysDsOrg, 2) = 'PS' & mbr = '' then
call serAddDsn m, ap || w
else if left(sysDsOrg, 2) = 'PO' then
call serAddPds m, ap || w
else
call err "bad sysDsOrg" sysDsOrg 'for' pds
end
return
endProcedure serAdd
serMap: procedure expose m.
parse arg dsn
pds = dsnSetMbr(dsn)
mbr = dsnGetMbr(dsn)
if m.ser.map.lastPds ^= pds then do
if symbol('m.ser.map.lastPds') == 'VAR' ,
& m.ser.map.lastPds ^== '' then
say m.ser.map.lastMbrs 'members from' m.ser.map.lastPds
m.ser.map.lastPds = pds
m.ser.map.lastMbrs = 0
end
m.ser.map.lastMbrs = m.ser.map.lastMbrs + 1
if mbr = '' then
mbr = dsnGetLev(pds, -1)
return "disp=shr dsn='''"dsn"'''"
return 'disp=shr dsn=wk.test('mbr')'
return ''
endProcedure serSave
serSave:
mbr = 'sv'translate(right(date('s'), 6), '0', ' ')
say 'mbr' mbr
call serialize 'zzz.serial('mbr')',
, "wk.clist wk.rexx wk.pli wk.jcl wk.pli wk.sql",
"wk.msgs wk.panels"
/* "zlib.* " */
return
endProcedure serSave
serIni:
parse arg serOutDsn
if m.ser.ini == 1 then
return
m.ser.ini = 1
m.ser.mark = ']'
m.ser.begin = 'begin'
m.ser.end = 'end'
m.ser.len = 10
return
serDesDS: procedure expose m.
parse arg dss, map
rx = readDS(wrNew(), dss)
call serDesReader rx, map
call reClose rx
call wrFree rx
return
endProcedure serDesDS
serDesReader: procedure expose m.
parse arg rx, map
call serIni
dsn = ''
ox = wrNew()
do while readLn(rx, li)
if abbrev(m.li, m.ser.mark) then do
rest = substr(m.li, 1 + length(m.ser.mark))
w2 = translate(word(rest, 2))
if abbrev(rest, m.ser.begin) then do
if dsn ^== '' then
call serErr rx, li, 'nested begin'
if w2 = '' then
call serErr rx, li, 'begin with empty dsngin'
dsn = w2
interpret map
writing = toDs ^= ''
if writing then
call wr2DS ox, toDs
iterate
end
else if abbrev(rest, m.ser.end) then do
if writing then
call wrClose ox
if dsn == '' then
call serErr rx, li, 'unpaired end'
if w2 ^== dsn then
call serErr rx, li, 'mismatched end for' dsn
dsn = ''
iterate
end
else if abbrev(rest, m.ser.mark) then do
m.li = rest
end
else do
call serErr rx, li, 'bad line'
end
end
if dsn == '' then
call serErr rx, li, 'data out of sequence'
if writing then
call writeLn ox, m.li
end
if dsn ^== '' then
call serErr rx, li, 'input ends without end'
dsn = ''
interpret map
call wrFree ox
return
endProcedure serDesReader
serErr: procedure expose m.
parse arg rx, li, msg
say '*** error' msg
say ' line ' m.li
say ' info ' readInfo(rx, '*')
call err msg
endProcedure serErr
serialize: procedure expose m.
parse upper arg toDsn, dsns
call serIni
wx = wr2DS(wrNew(), 'dsn='toDsn)
call outPush wx
call serLst dsns
call wrClose wx
call outPop
call wrFree wx
return
endProcedure serialize
serLst: procedure expose m.
parse upper arg dsns
px = piNew(2)
call piBegin px
call piDefine , "call lmx" quote(dsns)
call piBar
call piDefine ,, "call serDsn m.line"
call piEnd px
call wrClose px
call wrFree px
return
endProcedure serLst
serTst: procedure
return date(s) time()
endProcedure serTst
err:
call errA arg(1), 1
endSubroutine err
/* 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() '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
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = '~wk.pli(w*)'
else if dsn = '=' then do
ff = dsnAlloc('~wk.rexx',shr,abc)
dsn = '=abc'
end
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
if words(ff) > 1 then
interpret subword(ff, 2)
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
parse arg dsnSpec
parse value dsnSpec(dsnSpec) with dd disp dsn .
if disp = '=' then do
pds = 'ddName('dd')'
mbr = ''
end
else do
mbr = dsnGetMbr(dsn)
pds = "dataset('"dsnSetMbr(dsn, )"')"
end
call adrIsp "LMINIT DATAID(lmmId)" 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
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
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
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
/**********************************************************************
adr*: address an environment
***********************************************************************/
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
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
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' | addPrefix = 0 then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnSpec: procedure
parse upper arg spec
dd = '-'
dsn = '-'
disp = '-'
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 by 1
w = word(spec, wx)
if left(spec, 1) = '=' then
return substr(spec, 2) '= -'
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') & dsn = '-' then
dsn = dsn2jcl(substr(w, 5, length(w)-5), addPref)
else if dsn = '-' & w <> '' then
dsn = dsn2jcl(w, addPref)
else
return dd disp dsn subword(spec, wx)
end
endProcedure dsnSpec
dsnSpecDsn: procedure
parse arg spec
parse value dsnSpec(spec) with dd disp dsn .
if dsn = '' then
call 'err listDsi for dsn="" not implemented yet'
return dsn
endProcedure dsnSpecDsn
dsnAlloc: procedure
parse upper arg spec, defDisp, defDD
parse value dsnSpec(spec) with dd disp dsn rest
if disp = '=' then
return dd
if dd = '-' then
DD = defDD
if dd = '' then
dd = 'DD' || ooNew()
if disp = '-' then
disp = defDisp
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if dsn <> '-' then
disp = disp "dsn('"dsn"')"
call adrTso 'alloc dd('dd')' disp rest
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
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
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
call errA arg(1), 1
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt, ggHist
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
if ggHist ^== 1 then
exit setRc(12)
say 'divide by zero to show stack history'
x = 1 / 0
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggMsg
call help
call err ggMsg
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/