zOs/REXX.O08/GEOM
/* REXX *************************************************************
this editmacro moves points by different geometric maps
default
-f<xy> from point 0, 0
-g<xy> if set select only points in select all points
rectangle (-f, -g)
-r<a> rotate by a * 90 degrees 0
-d<a> rotate Direction values by a -r
-s<f> stretch by a factor f 1
-s<xy> stretch in x/y direction 1 1
-t<xy> to point -f
.<fr> from label .zf
.<to> to label .zl
<a> angle an integer
<f> a float, e.g 13 or 45.67
<xy> coordinatesgates eg 0,34.6
**********************************************************************/
call adrEdit('macro (args)')
say 'macro args' args
if args = '' then
args = '-f121.0,289.5 -t100,100 .a .b -r2'
call analyseArgs args
rst = rotStrTraArgs(optR optS optF optT)
say 'rst' rst '-f =>' rotStrTra(rst optF)
call adrEdit '(lnF) = linenum' labF
call adrEdit '(lnT) = linenum' labT
say 'labels' labF lnF labT lnT
selPos = 0
do lx=lnF to lnT
call adrEdit '(li) = line' lx
new = editPosition(lx, li)
if optD <> 0 & new <> '' then do
new = editDirection(lx, new)
end
if new <> '' then
call adrEdit "line" lx "= (new)"
end
exit
/* *****************************************
FIELD POSIT 100.0 100.0 Font A2828I direction BACK 11 ;
FIELD POSIT 81.0 100.0 Font A2828I direCTI DOWN 8 ;
FIELD POSIT 154.5 289.5 Font A1817I START 20 LENGTH 11 ;
**********************************************************/
/* *****************************************
FIELD POSIT 121.0 289.5 Font A2828I direction across 11 ;
FIELD POSIT 140.0 289.5 Font A2828I direCTI up 8 ;
FIELD POSIT 154.5 289.5 Font A1817I START 20 LENGTH 11 ;
FIELD POSIT 170.8 289.5 Font A1817I START 31 LENGTH 4 ;
SN: Seitennummer
FIELD POSIT 179.5 289.5 Font A1817I START 35 LENGTH 8 ;
FIELD POSIT 192.3 289.5 Font A1817I START 43 LENGTH 2 ;
**********************************************************/
call testGeom
editPosition: procedure expose optG RST
parse arg lx, li
up = translate(li)
px = pos('POSI', up)
if px < 1 then
return ''
xx = wordIndex(substr(li, px), 2) + px - 1
yx = wordIndex(substr(li, px), 3) + px - 1
rx = wordIndex(substr(li, px), 4) + px - 1
if rx < 1 then
rx = length(li) + 1
if xx <= px | yx <= xx then do
say 'missing words skipping line' lx li
return ''
end
x = word(substr(li, xx), 1)
y = word(substr(li, yx), 1)
if datatype(x) <> 'NUM' | datatype(y) <> 'NUM' then do
say 'not numeric skipping line' lx li
return ''
end
if optG <> '' then do
if word(optG, 1) > x | x > word(optG, 3) ,
| word(optG, 2) > y | y > word(optG, 4) then
return ''
end
n2 = rotStrTra(RST x y)
xS = pos(' ', li, px) + 1
rS = rx - (rx <= length(li))
return left(li, xS-1),
|| reformat(n2, substr(li, xS, rS-xS)),
|| substr(li, rS)
endProcedure editPosition
reformat: procedure
parse arg nums, like
res = ''
do wx=1 to words(nums)
w = word(nums, wx)
dx = pos('.', w)
if dx > 0 & length(w) - dx > 2 then
res = res format(w,,2)
else
res = res w
end
if length(res) > 0 then
res = substr(res, 2)
if length(res) >= length(like) then
return res
do wx=1 to words(nums)
rw = wordIndex(res, wx)
rx = verify(res, '. ', 'm', rw)
if rx < rw then
rx = length(res)
lw = wordIndex(like, wx)
lx = verify(like, '. ', 'm', lw)
if lx < lw then
lx = length(like)
if rx < lx then do;
if lx-rx >= length(like) - length(res) then
return left(res, rw-1) ,
|| left('',length(like) - length(res)),
|| substr(res,rw)
res = left(res, rw-1)left('',lx-rx)substr(res,rw)
if length(res) >= length(like) then
return res
end
end
return left(res, length(like))
endProcedure reformat
editDirection: procedure expose optD
parse arg lx, li
dirs = '0=ACROSS 1=DOWN 2=BACK 3=UP '
dx = pos('DIRE', translate(li))
if dx < 1 then
return ''
vx = wordIndex(substr(li, dx), 2) + dx - 1
w = translate(word(substr(li, vx), 1))
if w = '' then do
say 'direction missing' lx li
return ''
end
cx = pos('='w, dirs)
if cx < 2 then do
say 'direction illegal' w 'line' lx li
return ''
end
nx = angleNorm(optD + substr(dirs, cx-1, 1))
cx = pos(nx'=', dirs)
nn = word(substr(dirs, cx+2), 1)
qx = length(nn) - length(w)
if qx <= 0 then do
new = left(li, vx-1)nn||left('',-qx)substr(li,vx+length(w))
end
else do
rx = verify(substr(li, vx+length(w)), ' ');
if rx <= 0 then
rx = 1 + length(li)
else if rx - 2 > qx then
rx = vx + length(w) + qx
else
rx = vx + length(w) + rx - 2
new = left(li, vx-1)nn||strip(substr(li,rx), 't')
end
return new
end editDirection
analyseArgs: procedure expose optD optF optG optR optS optT labF labT
parse arg args
parse value '0 *' with optR optD optF optG optT labF labT
optS = 1 1
do wx=1 by 1
w = word(args, wx)
if w = '' then
leave
wL = left(w, 2)
wR = substr(w, 3)
select
when wL = '-d' then optD = wR
when wL = '-f' then optF = translate(wR, ' ', ',')
when wL = '-g' then optG = translate(wR, ' ', ',')
when wL = '-r' then optR = wR
when wL = '-s' then do
optS = translate(wR, ' ', ',')
if words(optS) = 1 then
optS = optS optS
end
when wL = '-t' then optT = translate(wR, ' ', ',')
when left(wL, 1) = '.' then do
if labF = '' then labF = w
else if labT = '' then labT = w
else call err 'more than two labels' w
end
when wL = '-?' | left(wL, 1) = '?' then do
call help
exit
end
otherwise call err 'bad Option' w
end /* select */
end /* do each word */
if optF = '' then optF = 0 0
if optT = '' then optT = optF
if labF = '' then labF = '.zf'
if labT = '' then labT = '.zl'
if optG <> '' then do
if word(optF, 1) <= word(optG, 1) then do
tl = word(optF, 1)
br = word(optG, 1)
end
else do
tl = word(optG, 1)
br = word(optF, 1)
end
if word(optF, 2) <= word(optG, 2) then
optG = tl word(optF, 2) br word(optG, 2)
else
optG = tl word(optG, 2) br word(optF, 2)
end
if optD = '*' then
optD = optR
else if optD = '' then
optD = 0
say 'analyseArgs -f='optF '-g='optG '-r='optR '-d='optD,
'-s='optS '-t='optT,
'from' labF 'to' labT
return
endProcedure analyseArgs
testGeom: procedure
say 'mod(112, 10)' mod(112, 10)
say 'mod(-112, 10)' mod(-112, 10)
say testRotate(0 4 5)
say testRotate(1 4 5)
say testRotate(1 4 '-5')
say testRotate(2 4 '-5')
say testRotate(3 4 '-5')
say testRotate(-297 4 '-5')
/* say testRotate(297.1 4 '-5') */
call testRST 0 1 1 1 2 7 9
call testRST 3 1 1 1 2 7 9
call testRST 2 2 3 1 2 7 9
return
end gestGeom
testRotate: procedure
parse arg aa
return 'rotate('aa') => 'rotate(aa)
endProcedure testRotate
rotate: procedure
parse arg a x y
select
when a=0 then return x y
when a=1 then return -y x
when a=2 then return -x (-y)
when a=3 then return y (-x)
otherwise return rotate(angleNorm(a) x y)
end
endProcedure rotate
testRST: procedure
parse arg r sx sy f g t u
aa = rotStrTraArgs(r sx sy f g t u)
say 'rotStrTraArgs('r sx sy f g t u ') =>' aa
say 'from RST('f g') =>' rotStrTra(aa f g)
say ' RST(-7 0 +7, -3) =>' left(rotStrTra(aa (-7) (-3)), 12) ,
left(rotStrTra(aa ( 0) (-3)), 12) ,
left(rotStrTra(aa (+7) (-3)), 12)
say ' RST(-7 0 +7, 0) =>' left(rotStrTra(aa (-7) ( 0)), 12) ,
left(rotStrTra(aa ( 0) ( 0)), 12) ,
left(rotStrTra(aa (+7) ( 0)), 12)
say ' RST(-7 0 +7, +3) =>' left(rotStrTra(aa (-7) (+3)), 12) ,
left(rotStrTra(aa ( 0) (+3)), 12) ,
left(rotStrTra(aa (+7) (+3)), 12)
return
end testRST
rotStrTra: procedure
parse arg r sx sy t u x y
return trans(stretch(sx sy rotate(r x y)) t u)
endProcedure trans
rotStrTraArgs: procedure
parse arg r sx sy f g t u
/* rotate and stretch origin (f g) */
z = stretch(sx sy rotate(r f g))
/* move it to (t u) */
return r sx sy trans(t u rotate(2 z))
endProcedure rotStrTraArgs
trans: procedure
parse arg a b x y
return (a+x) (b+y)
endProcedure trans
stretch: procedure
parse arg fx fy x y
return (fx*x) (fy*y)
endProcedure stretch
angleNorm: procedure
parse arg a
n = mod(a, 4)
if length(n) <> 1 | verify(n, '0123') > 0 then
call err 'bad angle' a
return n
endProcedure angleNorm
mod: procedure
parse arg a, b
if a >= 0 then
return a // b
else
return b + a // b
endProcedure mod
/************** member copy adr **************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnGetLLQ: get the llq from a dsn
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 = ''
***********************************************************************/
say dsnApp("a.b c(d e) f' ))) h")
say dsnApp("'a.b c(d e) f' ))) h")
call help
call errHelp(test errHelp)
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 dsn"'"
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
dsnGetLLQ: procedure
parse arg dsn
rx = pos('(', dsn) - 1
if rx < 0 then
rx = length(dsn)
lx = lastPos('.', dsn, rx)
return strip(substr(dsn, lx+1, rx-lx), 'b', "'")
endProcedure dsnGetLLQ
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg lvGrp, lvSt
return readNext(lvGrp, lvSt)
lmdEnd: procedure
parse arg grp
call readEnd 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
end 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
call sequence: readBegin, readNext*, readEnd
1. arg (dd) dd name, wird alloziert in begin und free in end
readNext 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 readNext('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 */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr reuse dsn('dsn')'
return /* end readBegin */
readNext:
parse arg lv_DD, lv_St
if adrTsoRc('execio 100 diskr' lv_DD '(stem' lv_St')') = 0 then
return 1
else if rc = 2 then
return (value(lv_St'0') > 0)
else
call err 'execio 100 diskr' lv_DD 'rc' rc
return /* end readNext */
readEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
call adrTso 'free dd('dd')'
return /* end readEnd */
/**********************************************************************
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
/**********************************************************************
variable Expansion: replace variable by their value
***********************************************************************/
varExpandTest: procedure
m.v.eins ='valEins'
m.v.zwei ='valZwei'
m.l.1='zeile eins geht unverändert'
m.l.2='$EINS auf zeile ${ZWEI} und \$EINS'
m.l.3='...$EINS?auf zeile ${ZWEI}und $EINS'
m.l.4='...$EINS,uf zeile ${ZWEI}und $EINS$$'
m.l.5='${EINS}$ZWEI$EINS${ZWEI}'
m.l.0=5
call varExpand l, r, v
do y=1 to m.r.0
say 'old' y m.l.y
say 'new' y m.r.y
end
return
endProcedure varExpandTest
varExpand: procedure expose m.
parse arg old, new, var
varChars = ,
'0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
do lx=1 to m.old.0
cx = 1
res = ''
do forever
dx = pos('$', m.old.lx, cx)
if dx < cx then do
m.new.lx = res || strip(substr(m.old.lx, cx), 't')
leave
end
res = res || substr(m.old.lx, cx, dx - cx)
if dx >= length(m.old.lx) then
call err '$ at end line m.'old'.'lx'='m.old.lx
if substr(m.old.lx, dx+1, 1) = '$' then do
res = res || '$'
cx = dx + 2
iterate
end
if substr(m.old.lx, dx+1, 1) = '{' then do
cx = pos('}', m.old.lx, dx+1)
if cx <= dx then
call err 'ending } missing line m.'old'.'lx'='m.old.lx
na = substr(m.old.lx, dx+2, cx-dx-2)
cx = cx + 1
end
else do
cx = verify(m.old.lx, varChars, 'N', dx+1);
if cx <= dx then
cx = length(m.old.lx) + 1
na = substr(m.old.lx, dx+1, cx-dx-1)
end
if symbol('m.v.na') = 'VAR' then
res = res || m.var.na
else
call err 'var' na 'not defined line m.'old'.'lx'='m.old.lx
end
m.new.0 = m.old.0
end
return /* var expand */
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggStmt, ggNo
if ggNo <> '1' then
ggStmt = 'execSql' ggStmt
address dsnRexx ggStmt
if rc = 0 then
nop /* say "sql ok:" ggStmt */
else if rc > 0 then
say "sql warn rc" rc sqlmsg()':' ggStmt
else
call err "sql rc" rc sqlmsg()':' ggStmt
return
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 0 then do
sRC = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
say 'subcom' sRc
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... */
if sqlCode = 0 then
return 'ok (sqlCode=0)'
else
return 'sqlCode='sqlCode,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))
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 tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
err:
parse arg txt
parse source s1 s2 s3 .
say 'fatal error in' s3':' txt
exit 12
errHelp: procedure
parse arg errMsg
say 'fatal error:' errMsg
call help
call err errMsg
endProcedure errHelp
help: procedure
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
endProcedure help
showtime:
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg