zOs/REXX.O13/ADRV1
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posRep: return the index of rep'th occurrence of needle
negativ rep are counted from the right
***********************************************************************/
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
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/**********************************************************************
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 = adrIspRC('lmdlist listid(&lmdId) option(save) group('grp')')
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 if res = 4 then do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
else
call err 'rc' res 'in lmdlist save' grp lev
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readDD(ggGrp, ggSt)
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(*)'
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
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readDD*, readDDEnd read dd in chunks
writeBegin, writeDD*, writeEnd write dsn in chunks
readDD liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readDD('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readDD */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
parse arg ggDD
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeDD 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine errA
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/